commit f47419766d219b043ed368c062e40dc78e41ed6e (HEAD, refs/remotes/origin/master) Author: Po Lu Date: Tue Dec 20 15:42:26 2022 +0800 Improve safety of calls to vendor-specific-keysyms * src/xterm.c (x_term_init): Wrap call to vendor-specific-keysyms inside safe_call. diff --git a/src/xterm.c b/src/xterm.c index a1acfa80744..60d48165650 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -29894,13 +29894,17 @@ #define NUM_ARGV 10 { char *vendor = ServerVendor (dpy); - /* Temporarily hide the partially initialized terminal. */ + /* Temporarily hide the partially initialized terminal. + Use safe_call so that if a signal happens, a partially + initialized display (and display connection) is not + kept around. */ terminal_list = terminal->next_terminal; unblock_input (); - kset_system_key_alist - (terminal->kboard, - call1 (Qvendor_specific_keysyms, - vendor ? build_string (vendor) : empty_unibyte_string)); + kset_system_key_alist (terminal->kboard, + safe_call1 (Qvendor_specific_keysyms, + (vendor + ? build_string (vendor) + : empty_unibyte_string))); block_input (); terminal->next_terminal = terminal_list; terminal_list = terminal; commit b4941419c5ba2818c82b58250eed9ac1c8f9dab9 Author: Stefan Kangas Date: Tue Dec 20 06:13:23 2022 +0100 ; Fix typos in some function names * lisp/cedet/semantic/decorate/include.el (semantic-decoration-unparsed-include-reference-reset): Rename from 'semantic-decoration-unparsed-include-refrence-reset'. * lisp/emacs-lisp/rx.el (rx--normalize-or-arg): Rename from 'rx--normalise-or-arg'. * lisp/frame.el (frame--current-background-mode): Rename from 'frame--current-backround-mode'. * lisp/url/url-future.el (url-future-canceled-p): Rename from 'url-future-cancelled-p'. Update all uses. Make old names into obsolete function aliases. diff --git a/lisp/cedet/semantic/decorate/include.el b/lisp/cedet/semantic/decorate/include.el index fe510c371e3..26785298e6b 100644 --- a/lisp/cedet/semantic/decorate/include.el +++ b/lisp/cedet/semantic/decorate/include.el @@ -790,9 +790,7 @@ semantic-reset ;; This is a hack. Add in something better? (semanticdb-notify-references table (lambda (tab _me) - (semantic-decoration-unparsed-include-refrence-reset tab) - )) - )) + (semantic-decoration-unparsed-include-reference-reset tab))))) (cl-defmethod semanticdb-partial-synchronize ((cache semantic-decoration-unparsed-include-cache) new-tags) @@ -805,7 +803,7 @@ semanticdb-synchronize "Synchronize a CACHE with some NEW-TAGS." (semantic-reset cache)) -(defun semantic-decoration-unparsed-include-refrence-reset (table) +(defun semantic-decoration-unparsed-include-reference-reset (table) "Refresh any highlighting in buffers referred to by TABLE. If TABLE is not in a buffer, do nothing." ;; This cache removal may seem odd in that we are "creating one", but @@ -835,6 +833,8 @@ semantic-decoration-unparsed-include-do-reset (semantic-decorate-add-decorations allinc) )))) +(define-obsolete-function-alias 'semantic-decoration-unparsed-include-refrence-reset + #'semantic-decoration-unparsed-include-reference-reset "30.1") (provide 'semantic/decorate/include) diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index f2a0dc54832..2ebdbc0efc4 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -254,20 +254,20 @@ rx--foldl (setq l (cdr l))) x) -(defun rx--normalise-or-arg (form) +(defun rx--normalize-or-arg (form) "Normalize the `or' argument FORM. Characters become strings, user-definitions and `eval' forms are expanded, and `or' forms are normalized recursively." (cond ((characterp form) (char-to-string form)) ((and (consp form) (memq (car form) '(or |))) - (cons (car form) (mapcar #'rx--normalise-or-arg (cdr form)))) + (cons (car form) (mapcar #'rx--normalize-or-arg (cdr form)))) ((and (consp form) (eq (car form) 'eval)) - (rx--normalise-or-arg (rx--expand-eval (cdr form)))) + (rx--normalize-or-arg (rx--expand-eval (cdr form)))) (t (let ((expanded (rx--expand-def form))) (if expanded - (rx--normalise-or-arg expanded) + (rx--normalize-or-arg expanded) form))))) (defun rx--all-string-or-args (body) @@ -302,7 +302,7 @@ rx--translate-or ((null (cdr body)) ; Single item. (rx--translate (car body))) (t - (let* ((args (mapcar #'rx--normalise-or-arg body)) + (let* ((args (mapcar #'rx--normalize-or-arg body)) (all-strings (catch 'rx--nonstring (rx--all-string-or-args args)))) (cond (all-strings ; Only strings. @@ -1494,6 +1494,9 @@ rx--pcase-expand ;; Obsolete internal symbol, used in old versions of the `flycheck' package. (define-obsolete-function-alias 'rx-submatch-n 'rx-to-string "27.1") +(define-obsolete-function-alias 'rx--normalise-or-arg + #'rx--normalize-or-arg "30.1") + (provide 'rx) ;;; rx.el ends here diff --git a/lisp/frame.el b/lisp/frame.el index 400f8a44eea..e4cd2cd8ae2 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -1188,7 +1188,7 @@ frame-background-mode (defvar inhibit-frame-set-background-mode nil) -(defun frame--current-backround-mode (frame) +(defun frame--current-background-mode (frame) (let* ((frame-default-bg-mode (frame-terminal-default-bg-mode frame)) (bg-color (frame-parameter frame 'background-color)) (tty-type (tty-type frame)) @@ -1218,7 +1218,7 @@ frame-set-background-mode face specs for the new background mode." (unless inhibit-frame-set-background-mode (let* ((bg-mode - (frame--current-backround-mode frame)) + (frame--current-background-mode frame)) (display-type (cond ((null (window-system frame)) (if (tty-display-color-p frame) 'color 'mono)) @@ -1297,7 +1297,7 @@ frame-terminal-default-bg-mode ;; :global t ;; :group 'faces ;; (when (eq dark-mode -;; (eq 'light (frame--current-backround-mode (selected-frame)))) +;; (eq 'light (frame--current-background-mode (selected-frame)))) ;; ;; FIXME: Change the face's SPEC instead? ;; (set-face-attribute 'default nil ;; :foreground (face-attribute 'default :background) @@ -3105,6 +3105,9 @@ frame-hide-title-bar-when-maximized frame 'undecorated (eq (alist-get 'fullscreen (frame-parameters frame)) 'maximized))) +(define-obsolete-function-alias 'frame--current-backround-mode + #'frame--current-background-mode "30.1") + (provide 'frame) ;;; frame.el ends here diff --git a/lisp/url/url-future.el b/lisp/url/url-future.el index 56787f7c5ec..737eea32c6a 100644 --- a/lisp/url/url-future.el +++ b/lisp/url/url-future.el @@ -53,7 +53,7 @@ url-future-completed-p (define-inline url-future-errored-p (url-future) (inline-quote (eq (url-future-status ,url-future) 'error))) -(define-inline url-future-cancelled-p (url-future) +(define-inline url-future-canceled-p (url-future) (inline-quote (eq (url-future-status ,url-future) 'cancel))) (defun url-future-finish (url-future &optional status) @@ -96,5 +96,8 @@ url-future-cancel (signal 'error 'url-future-already-done) (url-future-finish url-future 'cancel))) +(define-obsolete-function-alias 'url-future-cancelled-p + #'url-future-canceled-p "30.1") + (provide 'url-future) ;;; url-future.el ends here diff --git a/test/lisp/url/url-future-tests.el b/test/lisp/url/url-future-tests.el index 5083fc5abae..ec1796f7670 100644 --- a/test/lisp/url/url-future-tests.el +++ b/test/lisp/url/url-future-tests.el @@ -52,7 +52,7 @@ url-future-tests (should (equal (url-future-cancel tocancel) tocancel)) (should-error (url-future-call tocancel)) (should (null url-future-tests--saver)) - (should (url-future-cancelled-p tocancel)))) + (should (url-future-canceled-p tocancel)))) (provide 'url-future-tests) commit 8739cba1ee0336cef444ec07f170879e67f68202 Author: Sean Whitton Date: Mon Dec 19 15:15:48 2022 -0700 ; * lisp/vc/vc.el (vc-prepare-patch): Fix typo. diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index b40bb31b603..130214b840a 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -3433,7 +3433,7 @@ vc-prepare-patch When invoked with a numerical prefix argument, use the last N revisions. When invoked interactively in a Log View buffer with -marked revisions, use those these." +marked revisions, use those." (interactive (let ((revs (vc-prepare-patch-prompt-revisions)) to) (require 'message) commit aaca72806ecd60f28384fe839cdfe6a28a2b5d1f Author: Sean Whitton Date: Fri Dec 16 22:34:52 2022 -0700 vc-prepare-patch: Number the attached patches * lisp/gnus/mml.el (mml-attach-buffer): New FILENAME argument. * lisp/vc/vc.el (vc--subject-to-file-name): New function. (vc-prepare-patch): When vc-prepare-patches-separately is nil, generate file names for the attached patches. Call vc--subject-to-file-name, and then prepend numbers indicating the ordering of the patches (bug#60147). diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index ebd0adf2e25..dc86fe6db96 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -1484,10 +1484,12 @@ mml-dnd-attach-file (setq disposition (mml-minibuffer-read-disposition type nil file))) (mml-attach-file file type description disposition))))) -(defun mml-attach-buffer (buffer &optional type description disposition) +(defun mml-attach-buffer (buffer &optional type description disposition filename) "Attach a buffer to the outgoing MIME message. BUFFER is the name of the buffer to attach. See -`mml-attach-file' for details of operation." +`mml-attach-file' regarding TYPE, DESCRIPTION and DISPOSITION. +FILENAME is a suggested file name for the attachment should a +recipient wish to save a copy separate from the message." (interactive (let* ((buffer (read-buffer "Attach buffer: ")) (type (mml-minibuffer-read-type buffer "text/plain")) @@ -1497,9 +1499,10 @@ mml-attach-buffer ;; If in the message header, attach at the end and leave point unchanged. (let ((head (unless (message-in-body-p) (point)))) (if head (goto-char (point-max))) - (mml-insert-empty-tag 'part 'type type 'buffer buffer - 'disposition disposition - 'description description) + (apply #'mml-insert-empty-tag + 'part 'type type 'buffer buffer + 'disposition disposition 'description description + (and filename `(filename ,filename))) ;; When using Mail mode, make sure it does the mime encoding ;; when you send the message. (or (eq mail-user-agent 'message-user-agent) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 690c907c77e..b40bb31b603 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -3369,7 +3369,7 @@ vc-default-patch-addressee (declare-function message--name-table "message" (orig-string)) (declare-function mml-attach-buffer "mml" - (buffer &optional type description disposition)) + (buffer &optional type description disposition filename)) (declare-function log-view-get-marked "log-view" ()) (defun vc-default-prepare-patch (_backend rev) @@ -3410,6 +3410,19 @@ vc-prepare-patch-prompt-revisions (and-let* ((file (buffer-file-name))) (vc-working-revision file))))) +(defun vc--subject-to-file-name (subject) + "Generate a file name for a patch with subject line SUBJECT." + (let* ((stripped + (replace-regexp-in-string "\\`\\[.*PATCH.*\\]\\s-*" "" + subject)) + (truncated (if (length> stripped 50) + (substring stripped 0 50) + stripped))) + (concat + (string-trim (replace-regexp-in-string "\\W" "-" truncated) + "-+" "-+") + ".patch"))) + ;;;###autoload (defun vc-prepare-patch (addressee subject revisions) "Compose an Email sending patches for REVISIONS to ADDRESSEE. @@ -3466,11 +3479,17 @@ vc-prepare-patch (rfc822-goto-eoh) (forward-line) (save-excursion - (dolist (patch patches) - (mml-attach-buffer (buffer-name (plist-get patch :buffer)) - "text/x-patch" - (plist-get patch :subject) - "attachment"))) + (let ((i 0)) + (dolist (patch patches) + (let* ((patch-subject (plist-get patch :subject)) + (filename + (vc--subject-to-file-name patch-subject))) + (mml-attach-buffer + (buffer-name (plist-get patch :buffer)) + "text/x-patch" + patch-subject + "attachment" + (format "%04d-%s" (cl-incf i) filename)))))) (open-line 2))))) (defun vc-default-responsible-p (_backend _file) commit ae91da52335aafaff5405a49c23460082dfb460d Author: Eli Zaretskii Date: Mon Dec 19 19:34:36 2022 +0200 ; Fix byte-compilation warnings * lisp/cus-edit.el (custom-reset-standard-save-and-update): Fix byte-compilation warnings about using 'eq'. diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 8af4618dbd1..65eb066a554 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -903,9 +903,9 @@ custom-reset-standard-faces-list (defun custom-reset-standard-save-and-update () "Save settings and redraw after erasing customizations." (when (or (and custom-reset-standard-variables-list - (not (eq custom-reset-standard-variables-list '(t)))) + (not (equal custom-reset-standard-variables-list '(t)))) (and custom-reset-standard-faces-list - (not (eq custom-reset-standard-faces-list '(t))))) + (not (equal custom-reset-standard-faces-list '(t))))) ;; Save settings to file. (custom-save-all) ;; Set state of and redraw variables. commit 03e75b0f5f279f166db895ba4245bda6fa2f1ffe Author: Mattias Engdegård Date: Mon Dec 19 17:42:33 2022 +0100 called-interactively-p: cut broken comparison * lisp/subr.el (called-interactively-p): Remove attempt to detect `byte-code` frames; it wasn't done right but also does not seem to be necessary. Adjust comment that was out of date. diff --git a/lisp/subr.el b/lisp/subr.el index e142eaa8104..4fa63a1f3cd 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -6084,14 +6084,8 @@ called-interactively-p ;; Skip special forms (from non-compiled code). (and frame (null (car frame))) ;; Skip also `interactive-p' (because we don't want to know if - ;; interactive-p was called interactively but if it's caller was) - ;; and `byte-code' (idem; this appears in subexpressions of things - ;; like condition-case, which are wrapped in a separate bytecode - ;; chunk). - ;; FIXME: For lexical-binding code, this is much worse, - ;; because the frames look like "byte-code -> funcall -> #[...]", - ;; which is not a reliable signature. - (memq (nth 1 frame) '(interactive-p 'byte-code)) + ;; interactive-p was called interactively but if it's caller was). + (eq (nth 1 frame) 'interactive-p) ;; Skip package-specific stack-frames. (let ((skip (run-hook-with-args-until-success 'called-interactively-p-functions commit cb242bf1514ade34ab93b1db1ea7550093ae5839 Author: Vibhav Pant Date: Mon Dec 19 18:04:05 2022 +0530 Add support for additional memory checks using AddressSanitizer. When Emacs is compiled with AddressSanitizer support, enable poisoning/unpoisoning freed/unused Lisp objects and other internal memory management structures. If enabled, this will mark freed bytes that have been put on free lists for future use and initially allocated memory blocks/chunks as "poisoned", triggering an ASan error if they are accessed improperly. Structures are unpoisoned when they have been taken off their respective free lists. Additionally, add optional macros for performing unaligned loads, which when enabled by defining USE_SANITIZER_UNALIGNED_LOAD will use ASan provided functions for loading from unaligned addresses, which may help catch bugs that AddressSanitizer might otherwise miss. * configure.ac: Check for the existence of address and common sanitizer API headers. * src/lisp.h (UNALIGNED_LOAD_SIZE): New macro. If enabled, and the necessary sanitizer API is available, define it to __sanitizer_unaligned_load(64|32) depending on the word size of the architecture. * src/fns.c [HAVE_FAST_UNALIGNED_ACCESS] (Fstring_lessp): Use 'UNALIGNED_LOAD_SIZE' to perform unaligned loads from the two strings. * src/alloc.c (ASAN_POISON_ABLOCK, ASAN_UNPOISON_ABLOCK) (ASAN_POISON_INTERVAL_BLOCK, ASAN_UNPOISON_INTERVAL_BLOCK) (ASAN_POISON_INTERVAL, ASAN_UNPOISON_INTERVAL) (ASAN_PREPARE_DEAD_SDATA, ASAN_PREPARE_LIVE_SDATA) (ASAN_POISON_SBLOCK_DATA, ASAN_POISON_STRING_BLOCK) (ASAN_UNPOISON_STRING_BLOCK, ASAN_POISON_STRING) (ASAN_UNPOISON_STRING, ASAN_POISON_FLOAT_BLOCK) (ASAN_UNPOISON_FLOAT_BLOCK, ASAN_POISON_FLOAT) (ASAN_UNPOISON_FLOAT, ASAN_POISON_CONS_BLOCK) (ASAN_POISON_CONS, ASAN_UNPOISON_CONS) (ASAN_POISON_VECTOR_CONTENTS, ASAN_UNPOISON_VECTOR_CONTENTS) (ASAN_UNPOISON_VECTOR_BLOCK, ASAN_POISON_SYMBOL_BLOCK) (ASAN_UNPOISON_SYMBOL_BLOCK, ASAN_POISON_SYMBOL) (ASAN_UNPOISON_SYMBOL) [ADDRESS_SANITIZER]: New macros. When address sanitization is enabled, define them to poison/unpoison objects. (lisp_align_malloc): Poison newly allocated blocks on `free_ablock', unpoison ablocks taken from it respectively. (lisp_align_free): Poison individual ablocks when they are put on the free list, unpoison them when an entire `ablocks' chunk is being freed. (make_interval): Poison interval blocks on initial allocation, unpoison individual intervals on allocation and removal from `interval_free_list'. (sweep_intervals): Unpoison interval blocks before sweeping, poison dead/unmarked intervals. (allocate_string): Poison string blocks on initial allocation, unpoison Lisp_Strings on removal from the free list. (allocate_string_data): Poison `sblock' data on initial allocation, unpoison individual `sdata' contents on allocation or removal from the free list. Call `ASAN_PREPARE_LIVE_SDATA' on the new `sdata' struct. (sweep_strings): Unpoison string blocks before sweeping them, poisoning dead strings and their sdata afterwards. (compact_small_strings): Call `ASAN_PREPARE_LIVE_DATA' on the `sdata' to where compacted strings to moved to. (pin_string): Call `ASAN_PREPARE_DEAD_SDATA' on `old_sdata'. (make_float): Poison float blocks on allocation, unpoisoning individual Lisp_Floats on allocation or removal from `float_free_list'. (sweep_floats): Unpoison float blocks before sweeping, poison dead/unmarked floats. (free_cons): Poison `ptr'. (Fcons): Poison cons blocks on allocation, unpoisoning individual Lisp_Cons on allocation or removal from `cons_free_list'. (sweep_conses): Poison dead/unmarked conses. (setup_free_list): Poison vectors put on `vector_free_lists'. (allocate_vector_from_block): Unpoison vectors taken from the free list, poison excess vector bytes when vectors allocated from the free list are larger than requested. (sweep_vectors): Unpoison vector blocks before sweeping them. (Fmake_symbol): Poison symbol blocks on initial allocation, unpoisoning individual Lisp_Symbols on allocation or removal from `symbol_free_list'. (sweep_symbols): Unpoison symbol blocks before sweeping, poisoning dead/unmarked symbols. (live_string_holding, live_cons_holding, live_symbol_holding) (live_float_holding): When compiling with address sanitization and GC poisoning enabled, return NULL if the passed address is poisoned, or if the Lisp object it resides in is poisoned, avoiding a use-after-poison trigger if these functions are called on a pointer that might be referring to a now dead/swept object. * etc/DEBUG: Add information about enabling ASan memory poisoning. diff --git a/configure.ac b/configure.ac index 67c393e3351..5bd6645a256 100644 --- a/configure.ac +++ b/configure.ac @@ -1841,7 +1841,9 @@ AC_DEFUN coff.h pty.h sys/resource.h sys/utsname.h pwd.h utmp.h util.h - sanitizer/lsan_interface.h]) + sanitizer/lsan_interface.h + sanitizer/asan_interface.h + sanitizer/common_interface_defs.h]) AC_CACHE_CHECK([for ADDR_NO_RANDOMIZE], [emacs_cv_personality_addr_no_randomize], diff --git a/etc/DEBUG b/etc/DEBUG index ef9160a2090..01c75f8da7a 100644 --- a/etc/DEBUG +++ b/etc/DEBUG @@ -1002,6 +1002,28 @@ Address sanitization is incompatible with undefined-behavior sanitization, unfortunately. Address sanitization is also incompatible with the --with-dumping=unexec option of 'configure'. +*** Address poisoning/unpoisoning + +When compiled with address sanitization, Emacs will also try to mark +dead/free lisp objects as poisoned, forbidding them from being +accessed without being unpoisoned first. This adds an extra layer +of checking with objects in internal free lists, which may otherwise +evade traditional use-after-free checks. To disable this, add +'allow_user_poisoning=0' to ASAN_OPTIONS, or build Emacs with +'-DGC_ASAN_POISON_OBJECTS=0' in CFLAGS. + +While using GDB, memory addresses can be inspected by using helper +functions additionally provided by the ASan library: + + (gdb) call __asan_describe_address(ptr) + +To check whether an address range is poisoned or not, use: + + (gdb) call __asan_region_is_poisoned(ptr, 8) + +Additional functions can be found in the header +'sanitizer/asan_interface.h' in your compiler's headers directory. + ** Running Emacs under Valgrind Valgrind is free software that can be useful diff --git a/src/alloc.c b/src/alloc.c index 82e8901cf43..2975754124a 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -80,6 +80,37 @@ Copyright (C) 1985-2022 Free Software Foundation, Inc. #include #endif +/* AddressSanitizer exposes additional functions for manually marking + memory as poisoned/unpoisoned. When ASan is enabled and the needed + header is available, memory is poisoned when: + + * An ablock is freed (lisp_align_free), or ablocks are initially + allocated (lisp_align_malloc). + * An interval_block is initially allocated (make_interval). + * A dead INTERVAL is put on the interval free list + (sweep_intervals). + * A sdata is marked as dead (sweep_strings, pin_string). + * An sblock is initially allocated (allocate_string_data). + * A string_block is initially allocated (allocate_string). + * A dead string is put on string_free_list (sweep_strings). + * A float_block is initially allocated (make_float). + * A dead float is put on float_free_list. + * A cons_block is initially allocated (Fcons). + * A dead cons is put on cons_free_list (sweep_cons). + * A dead vector is put on vector_free_list (setup_on_free_list), + or a new vector block is allocated (allocate_vector_from_block). + Accordingly, objects reused from the free list are unpoisoned. + + This feature can be disabled wtih the run-time flag + `allow_user_poisoning' set to zero. */ +#if ADDRESS_SANITIZER && defined HAVE_SANITIZER_ASAN_INTERFACE_H \ + && !defined GC_ASAN_POISON_OBJECTS +# define GC_ASAN_POISON_OBJECTS 1 +# include +#else +# define GC_ASAN_POISON_OBJECTS 0 +#endif + /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects. We turn that on by default when ENABLE_CHECKING is defined; define GC_CHECK_MARKED_OBJECTS to zero to disable. */ @@ -1157,6 +1188,16 @@ #define ABLOCKS_BASE(abase) \ (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **) (abase))[-1]) #endif +#if GC_ASAN_POISON_OBJECTS +# define ASAN_POISON_ABLOCK(b) \ + __asan_poison_memory_region (&(b)->x, sizeof ((b)->x)) +# define ASAN_UNPOISON_ABLOCK(b) \ + __asan_unpoison_memory_region (&(b)->x, sizeof ((b)->x)) +#else +# define ASAN_POISON_ABLOCK(b) ((void) 0) +# define ASAN_UNPOISON_ABLOCK(b) ((void) 0) +#endif + /* The list of free ablock. */ static struct ablock *free_ablock; @@ -1235,6 +1276,7 @@ lisp_align_malloc (size_t nbytes, enum mem_type type) { abase->blocks[i].abase = abase; abase->blocks[i].x.next_free = free_ablock; + ASAN_POISON_ABLOCK (&abase->blocks[i]); free_ablock = &abase->blocks[i]; } intptr_t ialigned = aligned; @@ -1247,6 +1289,7 @@ lisp_align_malloc (size_t nbytes, enum mem_type type) eassert ((intptr_t) ABLOCKS_BUSY (abase) == aligned); } + ASAN_UNPOISON_ABLOCK (free_ablock); abase = ABLOCK_ABASE (free_ablock); ABLOCKS_BUSY (abase) = (struct ablocks *) (2 + (intptr_t) ABLOCKS_BUSY (abase)); @@ -1278,6 +1321,7 @@ lisp_align_free (void *block) #endif /* Put on free list. */ ablock->x.next_free = free_ablock; + ASAN_POISON_ABLOCK (ablock); free_ablock = ablock; /* Update busy count. */ intptr_t busy = (intptr_t) ABLOCKS_BUSY (abase) - 2; @@ -1290,9 +1334,12 @@ lisp_align_free (void *block) bool aligned = busy; struct ablock **tem = &free_ablock; struct ablock *atop = &abase->blocks[aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1]; - while (*tem) { +#if GC_ASAN_POISON_OBJECTS + __asan_unpoison_memory_region (&(*tem)->x, + sizeof ((*tem)->x)); +#endif if (*tem >= (struct ablock *) abase && *tem < atop) { i++; @@ -1421,6 +1468,24 @@ lrealloc (void *p, size_t size) static INTERVAL interval_free_list; +#if GC_ASAN_POISON_OBJECTS +# define ASAN_POISON_INTERVAL_BLOCK(b) \ + __asan_poison_memory_region ((b)->intervals, \ + sizeof ((b)->intervals)) +# define ASAN_UNPOISON_INTERVAL_BLOCK(b) \ + __asan_unpoison_memory_region ((b)->intervals, \ + sizeof ((b)->intervals)) +# define ASAN_POISON_INTERVAL(i) \ + __asan_poison_memory_region ((i), sizeof (*(i))) +# define ASAN_UNPOISON_INTERVAL(i) \ + __asan_unpoison_memory_region ((i), sizeof (*(i))) +#else +# define ASAN_POISON_INTERVAL_BLOCK(b) ((void) 0) +# define ASAN_UNPOISON_INTERVAL_BLOCK(b) ((void) 0) +# define ASAN_POISON_INTERVAL(i) ((void) 0) +# define ASAN_UNPOISON_INTERVAL(i) ((void) 0) +#endif + /* Return a new interval. */ INTERVAL @@ -1433,6 +1498,7 @@ make_interval (void) if (interval_free_list) { val = interval_free_list; + ASAN_UNPOISON_INTERVAL (val); interval_free_list = INTERVAL_PARENT (interval_free_list); } else @@ -1443,10 +1509,12 @@ make_interval (void) = lisp_malloc (sizeof *newi, false, MEM_TYPE_NON_LISP); newi->next = interval_block; + ASAN_POISON_INTERVAL_BLOCK (newi); interval_block = newi; interval_block_index = 0; } val = &interval_block->intervals[interval_block_index++]; + ASAN_UNPOISON_INTERVAL (val); } MALLOC_UNBLOCK_INPUT; @@ -1687,6 +1755,41 @@ init_strings (void) staticpro (&empty_multibyte_string); } +#if GC_ASAN_POISON_OBJECTS +/* Prepare s for denoting a free sdata struct, i.e, poison all bytes + in the flexible array member, except the first SDATA_OFFSET bytes. + This is only effective for strings of size n where n > sdata_size(n). + */ +# define ASAN_PREPARE_DEAD_SDATA(s, size) \ + do { \ + __asan_poison_memory_region ((s), sdata_size ((size))); \ + __asan_unpoison_memory_region (&(((s))->string), \ + sizeof (struct Lisp_String *)); \ + __asan_unpoison_memory_region (&SDATA_NBYTES ((s)), \ + sizeof (SDATA_NBYTES ((s)))); \ + } while (false) +/* Prepare s for storing string data for NBYTES bytes. */ +# define ASAN_PREPARE_LIVE_SDATA(s, nbytes) \ + __asan_unpoison_memory_region ((s), sdata_size ((nbytes))) +# define ASAN_POISON_SBLOCK_DATA(b, size) \ + __asan_poison_memory_region ((b)->data, (size)) +# define ASAN_POISON_STRING_BLOCK(b) \ + __asan_poison_memory_region ((b)->strings, STRING_BLOCK_SIZE) +# define ASAN_UNPOISON_STRING_BLOCK(b) \ + __asan_unpoison_memory_region ((b)->strings, STRING_BLOCK_SIZE) +# define ASAN_POISON_STRING(s) \ + __asan_poison_memory_region ((s), sizeof (*(s))) +# define ASAN_UNPOISON_STRING(s) \ + __asan_unpoison_memory_region ((s), sizeof (*(s))) +#else +# define ASAN_PREPARE_DEAD_SDATA(s, size) ((void) 0) +# define ASAN_PREPARE_LIVE_SDATA(s, nbytes) ((void) 0) +# define ASAN_POISON_SBLOCK_DATA(b, size) ((void) 0) +# define ASAN_POISON_STRING_BLOCK(b) ((void) 0) +# define ASAN_UNPOISON_STRING_BLOCK(b) ((void) 0) +# define ASAN_POISON_STRING(s) ((void) 0) +# define ASAN_UNPOISON_STRING(s) ((void) 0) +#endif #ifdef GC_CHECK_STRING_BYTES @@ -1805,12 +1908,14 @@ allocate_string (void) NEXT_FREE_LISP_STRING (s) = string_free_list; string_free_list = s; } + ASAN_POISON_STRING_BLOCK (b); } check_string_free_list (); /* Pop a Lisp_String off the free-list. */ s = string_free_list; + ASAN_UNPOISON_STRING (s); string_free_list = NEXT_FREE_LISP_STRING (s); MALLOC_UNBLOCK_INPUT; @@ -1870,6 +1975,7 @@ allocate_string_data (struct Lisp_String *s, #endif b = lisp_malloc (size + GC_STRING_EXTRA, clearit, MEM_TYPE_NON_LISP); + ASAN_POISON_SBLOCK_DATA (b, size); #ifdef DOUG_LEA_MALLOC if (!mmap_lisp_allowed_p ()) @@ -1891,6 +1997,8 @@ allocate_string_data (struct Lisp_String *s, { /* Not enough room in the current sblock. */ b = lisp_malloc (SBLOCK_SIZE, false, MEM_TYPE_NON_LISP); + ASAN_POISON_SBLOCK_DATA (b, SBLOCK_SIZE); + data = b->data; b->next = NULL; b->next_free = data; @@ -1903,10 +2011,19 @@ allocate_string_data (struct Lisp_String *s, } data = b->next_free; + if (clearit) - memset (SDATA_DATA (data), 0, nbytes); + { +#if GC_ASAN_POISON_OBJECTS + /* We are accessing SDATA_DATA (data) before it gets + * normally unpoisoned, so do it manually. */ + __asan_unpoison_memory_region (SDATA_DATA (data), nbytes); +#endif + memset (SDATA_DATA (data), 0, nbytes); + } } + ASAN_PREPARE_LIVE_SDATA (data, nbytes); data->string = s; b->next_free = (sdata *) ((char *) data + needed + GC_STRING_EXTRA); eassert ((uintptr_t) b->next_free % alignof (sdata) == 0); @@ -1998,12 +2115,16 @@ sweep_strings (void) int i, nfree = 0; struct Lisp_String *free_list_before = string_free_list; + ASAN_UNPOISON_STRING_BLOCK (b); + next = b->next; for (i = 0; i < STRING_BLOCK_SIZE; ++i) { struct Lisp_String *s = b->strings + i; + ASAN_UNPOISON_STRING (s); + if (s->u.s.data) { /* String was not on free-list before. */ @@ -2040,6 +2161,8 @@ sweep_strings (void) /* Put the string on the free-list. */ NEXT_FREE_LISP_STRING (s) = string_free_list; + ASAN_POISON_STRING (s); + ASAN_PREPARE_DEAD_SDATA (data, SDATA_NBYTES (data)); string_free_list = s; ++nfree; } @@ -2048,6 +2171,8 @@ sweep_strings (void) { /* S was on the free-list before. Put it there again. */ NEXT_FREE_LISP_STRING (s) = string_free_list; + ASAN_POISON_STRING (s); + string_free_list = s; ++nfree; } @@ -2174,6 +2299,7 @@ compact_small_strings (void) if (from != to) { eassert (tb != b || to < from); + ASAN_PREPARE_LIVE_SDATA (to, nbytes); memmove (to, from, size + GC_STRING_EXTRA); to->string->u.s.data = SDATA_DATA (to); } @@ -2525,6 +2651,7 @@ pin_string (Lisp_Object string) memcpy (s->u.s.data, data, size); old_sdata->string = NULL; SDATA_NBYTES (old_sdata) = size; + ASAN_PREPARE_DEAD_SDATA (old_sdata, size); } s->u.s.size_byte = -3; } @@ -2582,6 +2709,24 @@ #define XFLOAT_MARK(fptr) \ #define XFLOAT_UNMARK(fptr) \ UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr))) +#if GC_ASAN_POISON_OBJECTS +# define ASAN_POISON_FLOAT_BLOCK(fblk) \ + __asan_poison_memory_region ((fblk)->floats, \ + sizeof ((fblk)->floats)) +# define ASAN_UNPOISON_FLOAT_BLOCK(fblk) \ + __asan_unpoison_memory_region ((fblk)->floats, \ + sizeof ((fblk)->floats)) +# define ASAN_POISON_FLOAT(p) \ + __asan_poison_memory_region ((p), sizeof (struct Lisp_Float)) +# define ASAN_UNPOISON_FLOAT(p) \ + __asan_unpoison_memory_region ((p), sizeof (struct Lisp_Float)) +#else +# define ASAN_POISON_FLOAT_BLOCK(fblk) ((void) 0) +# define ASAN_UNPOISON_FLOAT_BLOCK(fblk) ((void) 0) +# define ASAN_POISON_FLOAT(p) ((void) 0) +# define ASAN_UNPOISON_FLOAT(p) ((void) 0) +#endif + /* Current float_block. */ static struct float_block *float_block; @@ -2606,6 +2751,7 @@ make_float (double float_value) if (float_free_list) { XSETFLOAT (val, float_free_list); + ASAN_UNPOISON_FLOAT (float_free_list); float_free_list = float_free_list->u.chain; } else @@ -2616,9 +2762,11 @@ make_float (double float_value) = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT); new->next = float_block; memset (new->gcmarkbits, 0, sizeof new->gcmarkbits); + ASAN_POISON_FLOAT_BLOCK (new); float_block = new; float_block_index = 0; } + ASAN_UNPOISON_FLOAT (&float_block->floats[float_block_index]); XSETFLOAT (val, &float_block->floats[float_block_index]); float_block_index++; } @@ -2690,6 +2838,19 @@ #define XUNMARK_CONS(fptr) \ static struct Lisp_Cons *cons_free_list; +#if GC_ASAN_POISON_OBJECTS +# define ASAN_POISON_CONS_BLOCK(b) \ + __asan_poison_memory_region ((b)->conses, sizeof ((b)->conses)) +# define ASAN_POISON_CONS(p) \ + __asan_poison_memory_region ((p), sizeof (struct Lisp_Cons)) +# define ASAN_UNPOISON_CONS(p) \ + __asan_unpoison_memory_region ((p), sizeof (struct Lisp_Cons)) +#else +# define ASAN_POISON_CONS_BLOCK(b) ((void) 0) +# define ASAN_POISON_CONS(p) ((void) 0) +# define ASAN_UNPOISON_CONS(p) ((void) 0) +#endif + /* Explicitly free a cons cell by putting it on the free-list. */ void @@ -2700,6 +2861,7 @@ free_cons (struct Lisp_Cons *ptr) cons_free_list = ptr; ptrdiff_t nbytes = sizeof *ptr; tally_consing (-nbytes); + ASAN_POISON_CONS (ptr); } DEFUN ("cons", Fcons, Scons, 2, 2, 0, @@ -2712,6 +2874,7 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, if (cons_free_list) { + ASAN_UNPOISON_CONS (cons_free_list); XSETCONS (val, cons_free_list); cons_free_list = cons_free_list->u.s.u.chain; } @@ -2722,10 +2885,12 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, struct cons_block *new = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS); memset (new->gcmarkbits, 0, sizeof new->gcmarkbits); + ASAN_POISON_CONS_BLOCK (new); new->next = cons_block; cons_block = new; cons_block_index = 0; } + ASAN_UNPOISON_CONS (&cons_block->conses[cons_block_index]); XSETCONS (val, &cons_block->conses[cons_block_index]); cons_block_index++; } @@ -2980,6 +3145,19 @@ large_vector_vec (struct large_vector *p) Lisp_Object zero_vector; +#if GC_ASAN_POISON_OBJECTS +# define ASAN_POISON_VECTOR_CONTENTS(v, bytes) \ + __asan_poison_memory_region ((v)->contents, (bytes)) +# define ASAN_UNPOISON_VECTOR_CONTENTS(v, bytes) \ + __asan_unpoison_memory_region ((v)->contents, (bytes)) +# define ASAN_UNPOISON_VECTOR_BLOCK(b) \ + __asan_unpoison_memory_region ((b)->data, sizeof ((b)->data)) +#else +# define ASAN_POISON_VECTOR_CONTENTS(v, bytes) ((void) 0) +# define ASAN_UNPOISON_VECTOR_CONTENTS(v, bytes) ((void) 0) +# define ASAN_UNPOISON_VECTOR_BLOCK(b) ((void) 0) +#endif + /* Common shortcut to setup vector on a free list. */ static void @@ -2992,6 +3170,7 @@ setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes) ptrdiff_t vindex = VINDEX (nbytes); eassert (vindex < VECTOR_MAX_FREE_LIST_INDEX); set_next_vector (v, vector_free_lists[vindex]); + ASAN_POISON_VECTOR_CONTENTS (v, nbytes - header_size); vector_free_lists[vindex] = v; } @@ -3039,6 +3218,7 @@ allocate_vector_from_block (ptrdiff_t nbytes) if (vector_free_lists[index]) { vector = vector_free_lists[index]; + ASAN_UNPOISON_VECTOR_CONTENTS (vector, nbytes - header_size); vector_free_lists[index] = next_vector (vector); return vector; } @@ -3052,12 +3232,18 @@ allocate_vector_from_block (ptrdiff_t nbytes) { /* This vector is larger than requested. */ vector = vector_free_lists[index]; + ASAN_UNPOISON_VECTOR_CONTENTS (vector, nbytes - header_size); vector_free_lists[index] = next_vector (vector); /* Excess bytes are used for the smaller vector, which should be set on an appropriate free list. */ restbytes = index * roundup_size + VBLOCK_BYTES_MIN - nbytes; eassert (restbytes % roundup_size == 0); +#if GC_ASAN_POISON_OBJECTS + /* Ensure that accessing excess bytes does not trigger ASan. */ + __asan_unpoison_memory_region (ADVANCE (vector, nbytes), + restbytes); +#endif setup_on_free_list (ADVANCE (vector, nbytes), restbytes); return vector; } @@ -3233,6 +3419,7 @@ sweep_vectors (void) for (vector = (struct Lisp_Vector *) block->data; VECTOR_IN_BLOCK (vector, block); vector = next) { + ASAN_UNPOISON_VECTOR_BLOCK (block); if (XVECTOR_MARKED_P (vector)) { XUNMARK_VECTOR (vector); @@ -3608,6 +3795,23 @@ #define SYMBOL_BLOCK_SIZE \ struct symbol_block *next; }; +#if GC_ASAN_POISON_OBJECTS +# define ASAN_POISON_SYMBOL_BLOCK(s) \ + __asan_poison_memory_region ((s)->symbols, sizeof ((s)->symbols)) +# define ASAN_UNPOISON_SYMBOL_BLOCK(s) \ + __asan_unpoison_memory_region ((s)->symbols, sizeof ((s)->symbols)) +# define ASAN_POISON_SYMBOL(sym) \ + __asan_poison_memory_region ((sym), sizeof (*(sym))) +# define ASAN_UNPOISON_SYMBOL(sym) \ + __asan_unpoison_memory_region ((sym), sizeof (*(sym))) + +#else +# define ASAN_POISON_SYMBOL_BLOCK(s) ((void) 0) +# define ASAN_UNPOISON_SYMBOL_BLOCK(s) ((void) 0) +# define ASAN_POISON_SYMBOL(sym) ((void) 0) +# define ASAN_UNPOISON_SYMBOL(sym) ((void) 0) +#endif + /* Current symbol block and index of first unused Lisp_Symbol structure in it. */ @@ -3661,6 +3865,7 @@ DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, if (symbol_free_list) { + ASAN_UNPOISON_SYMBOL (symbol_free_list); XSETSYMBOL (val, symbol_free_list); symbol_free_list = symbol_free_list->u.s.next; } @@ -3670,10 +3875,13 @@ DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, { struct symbol_block *new = lisp_malloc (sizeof *new, false, MEM_TYPE_SYMBOL); + ASAN_POISON_SYMBOL_BLOCK (new); new->next = symbol_block; symbol_block = new; symbol_block_index = 0; } + + ASAN_UNPOISON_SYMBOL (&symbol_block->symbols[symbol_block_index]); XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]); symbol_block_index++; } @@ -4561,6 +4769,11 @@ mem_delete_fixup (struct mem_node *x) live_string_holding (struct mem_node *m, void *p) { eassert (m->type == MEM_TYPE_STRING); +#if GC_ASAN_POISON_OBJECTS + if (__asan_address_is_poisoned (p)) + return NULL; +#endif + struct string_block *b = m->start; char *cp = p; ptrdiff_t offset = cp - (char *) &b->strings[0]; @@ -4577,6 +4790,10 @@ live_string_holding (struct mem_node *m, void *p) || off == offsetof (struct Lisp_String, u.s.data)) { struct Lisp_String *s = p = cp -= off; +#if GC_ASAN_POISON_OBJECTS + if (__asan_region_is_poisoned (s, sizeof (*s))) + return NULL; +#endif if (s->u.s.data) return s; } @@ -4598,6 +4815,11 @@ live_string_p (struct mem_node *m, void *p) live_cons_holding (struct mem_node *m, void *p) { eassert (m->type == MEM_TYPE_CONS); +#if GC_ASAN_POISON_OBJECTS + if (__asan_address_is_poisoned (p)) + return NULL; +#endif + struct cons_block *b = m->start; char *cp = p; ptrdiff_t offset = cp - (char *) &b->conses[0]; @@ -4615,6 +4837,10 @@ live_cons_holding (struct mem_node *m, void *p) || off == offsetof (struct Lisp_Cons, u.s.u.cdr)) { struct Lisp_Cons *s = p = cp -= off; +#if GC_ASAN_POISON_OBJECTS + if (__asan_region_is_poisoned (s, sizeof (*s))) + return NULL; +#endif if (!deadp (s->u.s.car)) return s; } @@ -4637,6 +4863,10 @@ live_cons_p (struct mem_node *m, void *p) live_symbol_holding (struct mem_node *m, void *p) { eassert (m->type == MEM_TYPE_SYMBOL); +#if GC_ASAN_POISON_OBJECTS + if (__asan_address_is_poisoned (p)) + return NULL; +#endif struct symbol_block *b = m->start; char *cp = p; ptrdiff_t offset = cp - (char *) &b->symbols[0]; @@ -4662,6 +4892,10 @@ live_symbol_holding (struct mem_node *m, void *p) || off == offsetof (struct Lisp_Symbol, u.s.next)) { struct Lisp_Symbol *s = p = cp -= off; +#if GC_ASAN_POISON_OBJECTS + if (__asan_region_is_poisoned (s, sizeof (*s))) + return NULL; +#endif if (!deadp (s->u.s.function)) return s; } @@ -4684,6 +4918,11 @@ live_symbol_p (struct mem_node *m, void *p) live_float_holding (struct mem_node *m, void *p) { eassert (m->type == MEM_TYPE_FLOAT); +#if GC_ASAN_POISON_OBJECTS + if (__asan_address_is_poisoned (p)) + return NULL; +#endif + struct float_block *b = m->start; char *cp = p; ptrdiff_t offset = cp - (char *) &b->floats[0]; @@ -4698,8 +4937,12 @@ live_float_holding (struct mem_node *m, void *p) && (b != float_block || offset / sizeof b->floats[0] < float_block_index)) { - p = cp - off; - return p; + struct Lisp_Float *f = (struct Lisp_Float *) (cp - off); +#if GC_ASAN_POISON_OBJECTS + if (__asan_region_is_poisoned (f, sizeof (*f))) + return NULL; +#endif + return f; } } return NULL; @@ -7181,11 +7424,13 @@ sweep_conses (void) struct Lisp_Cons *acons = &cblk->conses[pos]; if (!XCONS_MARKED_P (acons)) { + ASAN_UNPOISON_CONS (&cblk->conses[pos]); this_free++; cblk->conses[pos].u.s.u.chain = cons_free_list; cons_free_list = &cblk->conses[pos]; cons_free_list->u.s.car = dead_object (); - } + ASAN_POISON_CONS (&cblk->conses[pos]); + } else { num_used++; @@ -7203,6 +7448,7 @@ sweep_conses (void) { *cprev = cblk->next; /* Unhook from the free list. */ + ASAN_UNPOISON_CONS (&cblk->conses[0]); cons_free_list = cblk->conses[0].u.s.u.chain; lisp_align_free (cblk); } @@ -7229,6 +7475,7 @@ sweep_floats (void) for (struct float_block *fblk; (fblk = *fprev); ) { int this_free = 0; + ASAN_UNPOISON_FLOAT_BLOCK (fblk); for (int i = 0; i < lim; i++) { struct Lisp_Float *afloat = &fblk->floats[i]; @@ -7236,6 +7483,7 @@ sweep_floats (void) { this_free++; fblk->floats[i].u.chain = float_free_list; + ASAN_POISON_FLOAT (&fblk->floats[i]); float_free_list = &fblk->floats[i]; } else @@ -7252,7 +7500,8 @@ sweep_floats (void) { *fprev = fblk->next; /* Unhook from the free list. */ - float_free_list = fblk->floats[0].u.chain; + ASAN_UNPOISON_FLOAT (&fblk->floats[0]); + float_free_list = fblk->floats[0].u.chain; lisp_align_free (fblk); } else @@ -7278,13 +7527,14 @@ sweep_intervals (void) for (struct interval_block *iblk; (iblk = *iprev); ) { int this_free = 0; - + ASAN_UNPOISON_INTERVAL_BLOCK (iblk); for (int i = 0; i < lim; i++) { if (!iblk->intervals[i].gcmarkbit) { set_interval_parent (&iblk->intervals[i], interval_free_list); interval_free_list = &iblk->intervals[i]; + ASAN_POISON_INTERVAL (&iblk->intervals[i]); this_free++; } else @@ -7301,6 +7551,7 @@ sweep_intervals (void) { *iprev = iblk->next; /* Unhook from the free list. */ + ASAN_UNPOISON_INTERVAL (&iblk->intervals[0]); interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]); lisp_free (iblk); } @@ -7330,6 +7581,8 @@ sweep_symbols (void) for (sblk = symbol_block; sblk; sblk = *sprev) { + ASAN_UNPOISON_SYMBOL_BLOCK (sblk); + int this_free = 0; struct Lisp_Symbol *sym = sblk->symbols; struct Lisp_Symbol *end = sym + lim; @@ -7351,7 +7604,8 @@ sweep_symbols (void) sym->u.s.next = symbol_free_list; symbol_free_list = sym; symbol_free_list->u.s.function = dead_object (); - ++this_free; + ASAN_POISON_SYMBOL (sym); + ++this_free; } else { @@ -7370,6 +7624,7 @@ sweep_symbols (void) { *sprev = sblk->next; /* Unhook from the free list. */ + ASAN_UNPOISON_SYMBOL (&sblk->symbols[0]); symbol_free_list = sblk->symbols[0].u.s.next; lisp_free (sblk); } diff --git a/src/fns.c b/src/fns.c index b6e871ad49c..eeb65cadf3f 100644 --- a/src/fns.c +++ b/src/fns.c @@ -497,8 +497,13 @@ DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0, int ws = sizeof (word_t); const word_t *w1 = (const word_t *) SDATA (string1); const word_t *w2 = (const word_t *) SDATA (string2); - while (b < nb - ws + 1 && w1[b / ws] == w2[b / ws]) - b += ws; + while (b < nb - ws + 1) + { + if (UNALIGNED_LOAD_SIZE (w1, b / ws) + != UNALIGNED_LOAD_SIZE (w2, b / ws)) + break; + b += ws; + } } /* Scan forward to the differing byte. */ diff --git a/src/lisp.h b/src/lisp.h index 0f70f60d75c..be511a0eb9c 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -5296,6 +5296,26 @@ __lsan_ignore_object (void const *p) } #endif +/* If built with USE_SANITIZER_UNALIGNED_LOAD defined, use compiler + provided ASan functions to perform unaligned loads, allowing ASan + to catch bugs which it might otherwise miss. */ +#if defined HAVE_SANITIZER_COMMON_INTERFACE_DEFS_H \ + && defined ADDRESS_SANITIZER \ + && defined USE_SANITIZER_UNALIGNED_LOAD +# include +# if (SIZE_MAX == UINT64_MAX) +# define UNALIGNED_LOAD_SIZE(a, i) \ + (size_t) __sanitizer_unaligned_load64 ((void *) ((a) + (i))) +# elif (SIZE_MAX == UINT32_MAX) +# define UNALIGNED_LOAD_SIZE(a, i) \ + (size_t) __sanitizer_unaligned_load32 ((void *) ((a) + (i))) +# else +# define UNALIGNED_LOAD_SIZE(a, i) *((a) + (i)) +# endif +#else +# define UNALIGNED_LOAD_SIZE(a, i) *((a) + (i)) +#endif + extern void xputenv (const char *); extern char *egetenv_internal (const char *, ptrdiff_t); commit 79b1dede3444c07f943be34867bb2cdac236ab55 Author: Mattias Engdegård Date: Fri Dec 16 12:17:33 2022 +0100 Use equal and member instead of eq and memq * lisp/cedet/semantic/complete.el (semantic-displayer-show-request): * lisp/descr-text.el (describe-char-categories): * lisp/mh-e/mh-identity.el (mh-select-identity): * lisp/transient.el (transient--delay-post-command) (transient--post-command): * lisp/vc/vc-git.el (vc-git-create-tag): * test/lisp/emacs-lisp/cl-lib-tests.el (cl-lib-nth-value-test-multiple-values): * lisp/emulation/viper-cmd.el (viper-preserve-cursor-color): Use `equal` instead of `eq` and `member` instead of `memq` where the comparison is with literals without guaranteed identity. In some cases this change corrects evident bugs, in others it is mostly cosmetic. diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el index 00fe081acb5..1f372804dcc 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@ -1731,7 +1731,7 @@ semantic-displayer-show-request ;; Add any tail info. (setq msg (concat msg msg-tail)) ;; Display tooltip. - (when (not (eq msg "")) + (when (not (equal msg "")) (semantic-displayer-tooltip-show msg))))) ;;; Compatibility diff --git a/lisp/descr-text.el b/lisp/descr-text.el index f2ffddcf702..f105f292448 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -366,7 +366,7 @@ describe-char-padded-string ;; description is added to the category name as a tooltip (defsubst describe-char-categories (category-set) (let ((mnemonics (category-set-mnemonics category-set))) - (unless (eq mnemonics "") + (unless (equal mnemonics "") (list (mapconcat (lambda (x) (let* ((c (category-docstring x)) diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index 26793989d05..3b3caaf3e3c 100644 --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@ -194,9 +194,9 @@ viper-preserve-cursor-color viper-delete-backward-char viper-join-lines viper-delete-char)) - (memq (viper-event-key last-command-event) - '(up down left right (meta f) (meta b) - (control n) (control p) (control f) (control b))))) + (member (viper-event-key last-command-event) + '(up down left right (meta f) (meta b) + (control n) (control p) (control f) (control b))))) (defsubst viper-insert-state-pre-command-sentinel () (or (viper-preserve-cursor-color) diff --git a/lisp/mh-e/mh-identity.el b/lisp/mh-e/mh-identity.el index bcdf91299be..2507c677462 100644 --- a/lisp/mh-e/mh-identity.el +++ b/lisp/mh-e/mh-identity.el @@ -141,7 +141,7 @@ mh-select-identity (cons '("None") (mapcar #'list (mapcar #'car mh-identity-list))) nil t default nil default)) - (if (eq identity "None") + (if (equal identity "None") nil identity))) diff --git a/lisp/transient.el b/lisp/transient.el index 1cab697eecb..01c492c68c1 100644 --- a/lisp/transient.el +++ b/lisp/transient.el @@ -2203,7 +2203,7 @@ transient--delay-post-command (unless abort-only (setq post-command (lambda () "@transient--delay-post-command" - (let ((act (and (not (eq (this-command-keys-vector) [])) + (let ((act (and (not (equal (this-command-keys-vector) [])) (or (eq this-command command) ;; `execute-extended-command' was ;; used to call another command @@ -2241,7 +2241,7 @@ transient--post-command (transient--debug 'post-command) (transient--with-emergency-exit (cond - ((and (eq (this-command-keys-vector) []) + ((and (equal (this-command-keys-vector) []) (= (minibuffer-depth) (1+ transient--minibuffer-depth))) (transient--suspend-override) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 2876a983fb0..9f27f759d35 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1674,7 +1674,8 @@ vc-git-create-tag (if branchp "branch" "tag")))) (if branchp (vc-git-command nil 0 nil "checkout" "-b" name - (when (and start-point (not (eq start-point ""))) + (when (and start-point + (not (equal start-point ""))) start-point)) (vc-git-command nil 0 nil "tag" name))))) diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 4ec24e51e06..759138569e4 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -404,7 +404,7 @@ cl-lib-test-nth-value (ert-deftest cl-lib-nth-value-test-multiple-values () "While CL multiple values are an alias to list, these won't work." :expected-result :failed - (should (eq (cl-nth-value 0 '(2 3)) '(2 3))) + (should (equal (cl-nth-value 0 '(2 3)) '(2 3))) (should (= (cl-nth-value 0 1) 1)) (should (null (cl-nth-value 1 1))) (should-error (cl-nth-value -1 (cl-values 2 3)) :type 'args-out-of-range) commit 33af5371988e6329aa7e76ef4ae7fabb9ed72cf5 Author: Mattias Engdegård Date: Fri Dec 16 15:56:04 2022 +0100 Elide broken but unnecessary `if` optimisations * lisp/emacs-lisp/byte-opt.el (byte-optimize-if): Remove explicit clauses purposing to simplify (if X nil t) -> (not X) (if X t nil) -> (not (not X)) but never did so because of a coding mistake (eq instead of equal), found by a recently added warning. They weren't actually needed thanks to the optimiser's fixpoint iteration: we eventually get the same results through (if X nil t) -> (if (not X) t nil) -> (if (not X) t) -> (not X) (if X t nil) -> (if X t) -> (not (not X)) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 55b68c58438..898dfffef63 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1298,11 +1298,8 @@ byte-optimize-if (if else `(progn ,condition ,@else) condition)) - ;; (if X nil t) -> (not X) - ((and (eq then nil) (eq else '(t))) - `(not ,condition)) - ;; (if X t [nil]) -> (not (not X)) - ((and (eq then t) (or (null else) (eq else '(nil)))) + ;; (if X t) -> (not (not X)) + ((and (eq then t) (null else)) `(not ,(byte-opt--negate condition))) ;; (if VAR VAR X...) -> (or VAR (progn X...)) ((and (symbolp condition) (eq condition then)) commit 91d6b734216ed95f99f1f82ec6c1afd54af1c4dd Author: Mattias Engdegård Date: Fri Dec 16 11:08:02 2022 +0100 alist-get testfn argument evaluation correction * lisp/emacs-lisp/gv.el (alist-get): Evaluate TESTFN exactly once (previously up to 3 times). Reduce the macro-expansion to include a call to either assoc or assq, not both; this reduces the generated code size in some cases. diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 11251d7a963..48bc0269f36 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -417,9 +417,9 @@ alist-get (lambda (do key alist &optional default remove testfn) (macroexp-let2 macroexp-copyable-p k key (gv-letplace (getter setter) alist - (macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq))) - (assoc ,k ,getter ,testfn) - (assq ,k ,getter)) + (macroexp-let2 nil p (if (member testfn '(nil 'eq #'eq)) + `(assq ,k ,getter) + `(assoc ,k ,getter ,testfn)) (funcall do (if (null default) `(cdr ,p) `(if ,p (cdr ,p) ,default)) (lambda (v) commit 7f00dbe81a47d0b4dd18d28ebd18eb1448e8e377 Author: Michael Albinus Date: Mon Dec 19 10:23:50 2022 +0100 ; * test/infra/test-jobs.yml: Regenerate for the new use-package subdirectory. diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml index 51707c181b1..55ce590af89 100644 --- a/test/infra/test-jobs.yml +++ b/test/infra/test-jobs.yml @@ -493,6 +493,23 @@ test-lisp-url-inotify: target: emacs-inotify make_params: "-k -C test check-lisp-url" +test-lisp-use-package-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/use-package/*.el + - test/lisp/use-package/*.el + - test/lisp/use-package/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-use-package" + test-lisp-vc-inotify: stage: normal extends: [.job-template, .test-template] commit 39c6437e472a155414085b1ee57cf499b518aa57 Author: Michael Albinus Date: Mon Dec 19 10:23:14 2022 +0100 Ignore some handlers in ange-ftp.el * lisp/net/ange-ftp.el: Return nil for `file-acl', `file-notify-add-watch', `file-notify-rm-watch', `file-notify-valid-p', `file-system-info', `list-system-processes', `memory-info', `process-attributes', `set-file-acl', `set-file-selinux-context'. diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 6e17e417ea3..9781ebf863a 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -4498,6 +4498,25 @@ ange-ftp-hook-function (put 'process-file 'ange-ftp 'ange-ftp-process-file) (put 'start-file-process 'ange-ftp 'ignore) (put 'shell-command 'ange-ftp 'ange-ftp-shell-command) + +;; Do not execute system information functions. +(put 'file-system-info 'ange-ftp 'ignore) +(put 'list-system-processes 'ange-ftp 'ignore) +(put 'memory-info 'ange-ftp 'ignore) +(put 'process-attributes 'ange-ftp 'ignore) + +;; There aren't ACLs. `file-selinux-context' shall return '(nil nil +;; nil nil) if the file is nonexistent, so we let the default file +;; name handler do the job. +(put 'file-acl 'ange-ftp 'ignore) +;; (put 'file-selinux-context 'ange-ftp 'ignore) +(put 'set-file-acl 'ange-ftp 'ignore) +(put 'set-file-selinux-context 'ange-ftp 'ignore) + +;; There aren't file notifications. +(put 'file-notify-add-watch 'ange-ftp 'ignore) +(put 'file-notify-rm-watch 'ange-ftp 'ignore) +(put 'file-notify-valid-p 'ange-ftp 'ignore) ;;; Define ways of getting at unmodified Emacs primitives, ;;; turning off our handler.