mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-06 22:41:06 -08:00
Code Issues Projects Releases Wiki 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
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)