From 1d5b164109b59559d34c545c2a163fa067ca22b2 Mon Sep 17 00:00:00 2001 From: Robert Pluim Date: Tue, 23 May 2023 15:01:11 +0200 Subject: [PATCH 1/7] Stop adding the package directory to the load path The generated autoloads files for packages have been updating the load-path for the last decade. * lisp/emacs-lisp/package.el (package-activate-1): Don't update load-path with package directory. --- lisp/emacs-lisp/package.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 78017b77677..3d3158111b2 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -901,8 +901,7 @@ correspond to previously loaded files." (when reload (package--reload-previously-loaded pkg-desc)) (with-demoted-errors "Error loading autoloads: %s" - (load (package--autoloads-file-name pkg-desc) nil t)) - (add-to-list 'load-path (directory-file-name pkg-dir))) + (load (package--autoloads-file-name pkg-desc) nil t))) ;; Add info node. (when (file-exists-p (expand-file-name "dir" pkg-dir)) ;; FIXME: not the friendliest, but simple. From 87da87730f9f69fa29a73ac504b690c40b1bc98f Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Tue, 23 May 2023 15:32:20 +0200 Subject: [PATCH 2/7] Improve check for ANSI control escape sequences in Tramp * lisp/net/tramp-sh.el (tramp-barf-if-no-shell-prompt): Remove `ansi-color-control-seq-regexp'. * lisp/net/tramp.el (tramp-terminal-type): Fix docstring. (tramp-process-one-action): Delete ANSI control escape sequences in buffer. (Bug#63539) --- lisp/net/tramp-sh.el | 9 ++++----- lisp/net/tramp.el | 15 +++++++-------- 2 files changed, 11 insertions(+), 13 deletions(-) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index d4933ad7ba6..0b3ce07d275 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -4316,7 +4316,6 @@ seconds. If not, it produces an error message with the given ERROR-ARGS." proc timeout (rx (| (regexp shell-prompt-pattern) (regexp tramp-shell-prompt-pattern)) - (? (regexp ansi-color-control-seq-regexp)) eos)) (error (delete-process proc) @@ -5294,10 +5293,10 @@ function waits for output unless NOOUTPUT is set." (tramp-error proc 'file-error "Process `%s' not available, try again" proc)) (with-current-buffer (process-buffer proc) (let* (;; Initially, `tramp-end-of-output' is "#$ ". There might - ;; be leading escape sequences, which must be ignored. - ;; Busyboxes built with the EDITING_ASK_TERMINAL config - ;; option send also escape sequences, which must be - ;; ignored. + ;; be leading ANSI control escape sequences, which must be + ;; ignored. Busyboxes built with the EDITING_ASK_TERMINAL + ;; config option send also ANSI control escape sequences, + ;; which must be ignored. (regexp (rx (* (not (any "#$\n"))) (literal tramp-end-of-output) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index f986d65d944..b27465a98fa 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -697,7 +697,7 @@ See also `tramp-yesno-prompt-regexp'." (defcustom tramp-terminal-type "dumb" "Value of TERM environment variable for logging in to remote host. Because Tramp wants to parse the output of the remote shell, it is easily -confused by ANSI color escape sequences and suchlike. Often, shell init +confused by ANSI control escape sequences and suchlike. Often, shell init files conditionalize this setup based on the TERM environment variable." :group 'tramp :type 'string) @@ -5709,18 +5709,17 @@ Wait, until the connection buffer changes." "Wait for output from the shell and perform one action. See `tramp-process-actions' for the format of ACTIONS." (let ((case-fold-search t) - (shell-prompt-pattern - (rx (regexp shell-prompt-pattern) - (? (regexp ansi-color-control-seq-regexp)))) - (tramp-shell-prompt-pattern - (rx (regexp tramp-shell-prompt-pattern) - (? (regexp ansi-color-control-seq-regexp)))) tramp-process-action-regexp found todo item pattern action) (while (not found) ;; Reread output once all actions have been performed. ;; Obviously, the output was not complete. (while (tramp-accept-process-output proc)) + ;; Remove ANSI control escape sequences. + (with-current-buffer (tramp-get-connection-buffer vec) + (goto-char (point-min)) + (while (re-search-forward ansi-color-control-seq-regexp nil t) + (replace-match ""))) (setq todo actions) (while todo (setq item (pop todo) @@ -6280,7 +6279,7 @@ to cache the result. Return the modified ATTR." (with-tramp-file-property ,vec ,localname "file-attributes" (when-let ((attr ,attr)) (save-match-data - ;; Remove color escape sequences from symlink. + ;; Remove ANSI control escape sequences from symlink. (when (stringp (car attr)) (while (string-match ansi-color-control-seq-regexp (car attr)) (setcar attr (replace-match "" nil nil (car attr))))) From 92ccb6ba83076a40f3bfc7906913346a5b3a7a92 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 24 Aug 2022 18:08:37 +0200 Subject: [PATCH 3/7] comp: Account non builtin types in type hierarchy * lisp/emacs-lisp/cl-macs.el (cl--struct-all-parents): Add comment. * lisp/emacs-lisp/cl-preloaded.el (cl--struct-get-class): Likewise. * lisp/emacs-lisp/comp-cstr.el (comp--cl-class-hierarchy) (comp--all-classes): New functions. (comp-cstr-ctxt): Add `typeof-types' field. * lisp/emacs-lisp/comp-cstr.el (comp-supertypes) (comp-union-typesets): Update to use non builtin types. --- lisp/emacs-lisp/cl-macs.el | 1 + lisp/emacs-lisp/cl-preloaded.el | 1 + lisp/emacs-lisp/comp-cstr.el | 24 ++++++++++++++++++++++-- 3 files changed, 24 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 8fdafe18c50..6590b1baa1e 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3249,6 +3249,7 @@ To see the documentation for a defined struct type, use ;;; Add cl-struct support to pcase +;;In use by comp.el (defun cl--struct-all-parents (class) (when (cl--struct-class-p class) (let ((res ()) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 5235be52996..f410270d340 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -113,6 +113,7 @@ supertypes from the most specific to least specific.") (record 'cl-slot-descriptor name initform type props))) +;; In use by comp.el (defun cl--struct-get-class (name) (or (if (not (symbolp name)) name) (cl--find-class name) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index d4200c16c19..869b0619160 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -86,7 +86,27 @@ Integer values are handled in the `range' slot.") (ret nil :type (or comp-cstr comp-cstr-f) :documentation "Returned value.")) +(defun comp--cl-class-hierarchy (x) + "Given a class name `x' return its hierarchy." + `(,@(mapcar #'cl--struct-class-name (cl--struct-all-parents + (cl--struct-get-class x))) + atom + t)) + +(defun comp--all-classes () + "Return all non built-in type names currently defined." + (let (res) + (mapatoms (lambda (x) + (when (cl-find-class x) + (push x res))) + obarray) + res)) + (cl-defstruct comp-cstr-ctxt + (typeof-types (append comp--typeof-builtin-types + (mapcar #'comp--cl-class-hierarchy (comp--all-classes))) + :type list + :documentation "Type hierarchy.") (union-typesets-mem (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for `comp-union-typesets'.") @@ -230,7 +250,7 @@ Return them as multiple value." (cl-loop named outer with found = nil - for l in comp--typeof-builtin-types + for l in (comp-cstr-ctxt-typeof-types comp-ctxt) do (cl-loop for x in l for i from (length l) downto 0 @@ -273,7 +293,7 @@ Return them as multiple value." (cl-loop with types = (apply #'append typesets) with res = '() - for lane in comp--typeof-builtin-types + for lane in (comp-cstr-ctxt-typeof-types comp-ctxt) do (cl-loop with last = nil for x in lane From f4de81af8fc54ef278cdb76fbc5885ed7d05b2d7 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 24 Aug 2022 18:41:19 +0200 Subject: [PATCH 4/7] * lisp/emacs-lisp/comp.el (comp-fwprop-call): Extend to understand `record' --- lisp/emacs-lisp/comp.el | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 2e07b0b0e60..289c5bf2ac4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3198,7 +3198,11 @@ Fold the call in case." (+ (comp-cstr-add lval args)) (- (comp-cstr-sub lval args)) (1+ (comp-cstr-add lval `(,(car args) ,comp-cstr-one))) - (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one)))))) + (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one))) + (record (when (comp-cstr-imm-vld-p (car args)) + (comp-cstr-shallow-copy lval + (comp-type-spec-to-cstr + (comp-cstr-imm (car args))))))))) (defun comp-fwprop-insn (insn) "Propagate within INSN." From d03dd07774acfa690e5b63a7dbf81fb319aeedf4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 24 Aug 2022 23:31:28 +0200 Subject: [PATCH 5/7] comp: Make use of predicates in propagation for non builtin types * lisp/emacs-lisp/comp-cstr.el (comp-cstr-ctxt): Add `pred-type-h' slot. * lisp/emacs-lisp/comp.el (comp-known-predicate-p) (comp-pred-to-cstr): Update. --- lisp/emacs-lisp/comp-cstr.el | 8 ++++++++ lisp/emacs-lisp/comp.el | 7 +++++-- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 869b0619160..35e9ac45919 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -107,6 +107,14 @@ Integer values are handled in the `range' slot.") (mapcar #'comp--cl-class-hierarchy (comp--all-classes))) :type list :documentation "Type hierarchy.") + (pred-type-h (cl-loop with h = (make-hash-table :test #'eq) + for class-name in (comp--all-classes) + for pred = (get class-name 'cl-deftype-satisfies) + when pred + do (puthash pred class-name h) + finally return h) + :type hash-table + :documentation "Hash pred -> type.") (union-typesets-mem (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for `comp-union-typesets'.") diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 289c5bf2ac4..fe72f0e73a4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -641,11 +641,14 @@ Useful to hook into pass checkers.") (defun comp-known-predicate-p (predicate) "Return t if PREDICATE is known." - (when (gethash predicate comp-known-predicates-h) t)) + (when (or (gethash predicate comp-known-predicates-h) + (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))) + t)) (defun comp-pred-to-cstr (predicate) "Given PREDICATE, return the corresponding constraint." - (gethash predicate comp-known-predicates-h)) + (or (gethash predicate comp-known-predicates-h) + (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))) (defconst comp-symbol-values-optimizable '(most-positive-fixnum most-negative-fixnum) From 6c781b5d252057e04c612d0a2e3e10b91a1cfa96 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 17 May 2023 18:00:24 +0200 Subject: [PATCH 6/7] comp: Propagate pre slot access type check * lisp/loadup.el (max-lisp-eval-depth): Increase `max-lisp-eval-depth' to 3400. * lisp/emacs-lisp/comp.el (comp-add-cond-cstrs): Pattern match pre slot access type check and add constraint. * lisp/emacs-lisp/comp-cstr.el (comp-cstr-cl-tag-p) (comp-cstr-cl-tag): New functions. * lisp/emacs-lisp/comp.el (make-comp-mvar): Add neg parameter. --- lisp/emacs-lisp/comp-cstr.el | 17 +++++++++++++++++ lisp/emacs-lisp/comp.el | 17 ++++++++++++++++- lisp/loadup.el | 2 +- 3 files changed, 34 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 35e9ac45919..e9132552506 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -895,6 +895,23 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (null (neg cstr)) (equal (typeset cstr) '(cons))))) +;; Move to comp.el? +(defsubst comp-cstr-cl-tag-p (cstr) + "Return non-nil if CSTR is a CL tag." + (with-comp-cstr-accessors + (and (null (range cstr)) + (null (neg cstr)) + (null (typeset cstr)) + (length= (valset cstr) 1) + (string-match (rx "cl-struct-" (group-n 1 (1+ not-newline)) "-tags") + (symbol-name (car (valset cstr))))))) + +(defsubst comp-cstr-cl-tag (cstr) + "If CSTR is a CL tag return its tag name." + (with-comp-cstr-accessors + (and (comp-cstr-cl-tag-p cstr) + (intern (match-string 1 (symbol-name (car (valset cstr)))))))) + (defun comp-cstr-= (dst op1 op2) "Constraint OP1 being = OP2 setting the result into DST." (with-comp-cstr-accessors diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index fe72f0e73a4..8e59c06d40e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1543,7 +1543,7 @@ STACK-OFF is the index of the first slot frame involved." for sp from stack-off collect (comp-slot-n sp)))) -(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) +(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type neg) "`comp-mvar' initializer." (let ((mvar (make--comp-mvar :slot slot))) (when const-vld @@ -1551,6 +1551,8 @@ STACK-OFF is the index of the first slot frame involved." (setf (comp-cstr-imm mvar) constant)) (when type (setf (comp-mvar-typeset mvar) (list type))) + (when neg + (setf (comp-mvar-neg mvar) t)) mvar)) (defun comp-new-frame (size vsize &optional ssa) @@ -2546,6 +2548,19 @@ TARGET-BB-SYM is the symbol name of the target block." for insns-seq on (comp-block-insns b) do (pcase insns-seq + (`((set ,(and (pred comp-mvar-p) mvar-tested-copy) + ,(and (pred comp-mvar-p) mvar-tested)) + (set ,(and (pred comp-mvar-p) mvar-1) + (call type-of ,(and (pred comp-mvar-p) mvar-tested-copy))) + (set ,(and (pred comp-mvar-p) mvar-2) + (call symbol-value ,(and (pred comp-cstr-cl-tag-p) mvar-tag))) + (set ,(and (pred comp-mvar-p) mvar-3) + (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2))) + (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2)) + (push `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag))) + (comp-block-insns (comp-add-cond-cstrs-target-block b bb2))) + (push `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag) :neg t)) + (comp-block-insns (comp-add-cond-cstrs-target-block b bb1)))) (`((set ,(and (pred comp-mvar-p) cmp-res) (,(pred comp-call-op-p) ,(and (or (pred comp-equality-fun-p) diff --git a/lisp/loadup.el b/lisp/loadup.el index 1cc70348267..7044a629848 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -103,7 +103,7 @@ ;; During bootstrapping the byte-compiler is run interpreted ;; when compiling itself, which uses a lot more stack ;; than usual. - (setq max-lisp-eval-depth 2200))) + (setq max-lisp-eval-depth 3400))) (if (eq t purify-flag) ;; Hash consing saved around 11% of pure space in my tests. From 9ad997cd68981fe6c6933b6977fdae23e84e6a75 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 23 May 2023 15:13:08 +0200 Subject: [PATCH 7/7] * test/src/comp-tests.el: Add some ret type tests for non builtin types --- test/src/comp-tests.el | 36 +++++++++++++++++++++++++++++++++++- 1 file changed, 35 insertions(+), 1 deletion(-) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4682cac450e..673a9342f1f 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -875,6 +875,8 @@ Return a list of results." ret-type)))) (cl-eval-when (compile eval load) + (cl-defstruct comp-foo a b) + (cl-defstruct (comp-bar (:include comp-foo)) c) (defconst comp-tests-type-spec-tests ;; Why we quote everything here, you ask? So that values of ;; `most-positive-fixnum' and `most-negative-fixnum', which can be @@ -1404,7 +1406,39 @@ Return a list of results." (if (eq x 0) (error "") (1+ x))) - 'number))) + 'number) + + ;; 75 + ((defun comp-tests-ret-type-spec-f () + (make-comp-foo)) + 'comp-foo) + + ;; 76 + ((defun comp-tests-ret-type-spec-f () + (make-comp-bar)) + 'comp-bar) + + ;; 77 + ((defun comp-tests-ret-type-spec-f (x) + (setf (comp-foo-a x) 2) + x) + 'comp-foo) + + ;; 78 + ((defun comp-tests-ret-type-spec-f (x) + (if x + (if (> x 11) + x + (make-comp-foo)) + (make-comp-bar))) + '(or comp-foo float (integer 12 *))) + + ;; 79 + ((defun comp-tests-ret-type-spec-f (x) + (if (comp-foo-p x) + x + (error ""))) + 'comp-foo))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) ()