mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-22 07:09:54 +00:00
Code Issues Releases Activity

(pcase--app-subst-match): Try and fix performance regression (bug#71398)

Browse Source 
* lisp/emacs-lisp/pcase.el (pcase--app-subst-match): Optimize matches
against (quote VAL).
* test/lisp/emacs-lisp/pcase-tests.el (pcase-tests-quote-optimization):
Add new test case.
This commit is contained in:
Stefan Monnier 2024-06-08 17:34:30 -04:00
parent 15f515c7a3
commit e9a0256a55
2 changed files with 36 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
lisp/emacs-lisp/pcase.el
View File

@ -857,13 +857,36 @@ A and B can be one of:
(or (keywordp upat) (integerp upat) (stringp upat)))
(defun pcase--app-subst-match (match sym fun nsym)
"Refine MATCH knowing that NSYM = (funcall FUN SYM)."
(cond
((eq (car-safe match) 'match)
(if (and (eq sym (cadr match))
(eq 'app (car-safe (cddr match)))
(equal fun (nth 1 (cddr match))))
(pcase--match nsym (nth 2 (cddr match)))
match))
(cond
((not (eq sym (cadr match))) match)
((and (eq 'app (car-safe (cddr match)))
(equal fun (nth 1 (cddr match))))
;; MATCH is (match SYM app FUN UPAT), so we can refine it to refer to
;; NSYM rather than re-compute (funcall FUN SYM).
(pcase--match nsym (nth 2 (cddr match))))
((eq 'quote (car-safe (cddr match)))
;; MATCH is (match SYM quote VAL), so we can decompose it into
;; (match NSYM quote (funcall FUN VAL)) plus a check that
;; the part of VAL not included in (funcall FUN VAL) still
;; result is SYM matching (quote VAL). (bug#71398)
(condition-case nil
`(and (match ,nsym . ',(funcall fun (nth 3 match)))
;; FIXME: "the part of VAL not included in (funcall FUN VAL)"
;; is hard to define for arbitrary FUN. We do it only when
;; FUN is `c[ad]r', and for the rest we just preserve
;; the original `match' which is not optimal but safe.
,(if (and (memq fun '(car cdr car-safe cdr-safe))
(consp (nth 3 match)))
(let ((otherfun (if (memq fun '(car car-safe))
#'cdr-safe #'car-safe)))
`(match ,(cadr match) app ,otherfun
',(funcall otherfun (nth 3 match))))
match))
(error match)))
(t match)))
((memq (car-safe match) '(or and))
`(,(car match)
,@(mapcar (lambda (match)

9
test/lisp/emacs-lisp/pcase-tests.el
View File

@ -83,7 +83,14 @@
(should-not (pcase-tests-grep
'FOO (macroexpand '(pcase EXP
(`(,_ . ,_) (BAR))
('(a b) (FOO)))))))
('(a b) (FOO))))))
(let ((exp1 (macroexpand '(pcase EXP
(`(`(,(or 'a1 'b1)) (FOO1)))
('(c) (FOO2))
('(d) (FOO3))))))
(should (= 1 (with-temp-buffer (prin1 exp1 (current-buffer))
(goto-char (point-min))
(count-matches "(FOO3)"))))))
(ert-deftest pcase-tests-bug14773 ()
(let ((f (lambda (x)