mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-12 09:28:24 +00:00
Code Issues Releases Activity

* lisp/emacs-lisp/pcase.el (pcase-compile-patterns): New function (bug#47261)

Browse Source 
Extracted from `pcase--expand`.
(pcase--expand): Use it.
This commit is contained in:
Stefan Monnier 2021-03-19 17:42:22 -04:00
parent 3af2cee64b
commit 937b6c18bd
2 changed files with 96 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
etc/NEWS
View File

@ -433,6 +433,9 @@ to nil. This was already sometimes the case, but it is now guaranteed.
This is like '(pred (lambda (x) (not (FUN x))))' but results This is like '(pred (lambda (x) (not (FUN x))))' but results
in better code. in better code.
---
*** New function 'pcase-compile-patterns' to write other macros.
+++ +++
** profiler.el ** profiler.el
The results displayed by 'profiler-report' now have the usage figures The results displayed by 'profiler-report' now have the usage figures

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

@ -207,6 +207,7 @@ If EXP fails to match any of the patterns in CASES, an error is signaled."
(pcase--dontwarn-upats (cons x pcase--dontwarn-upats))) (pcase--dontwarn-upats (cons x pcase--dontwarn-upats)))
(pcase--expand (pcase--expand
;; FIXME: Could we add the FILE:LINE data in the error message? ;; FIXME: Could we add the FILE:LINE data in the error message?
;; FILE is available from `macroexp-file-name'.
exp (append cases `((,x (error "No clause matching `%S'" ,x))))))) exp (append cases `((,x (error "No clause matching `%S'" ,x)))))))
;;;###autoload ;;;###autoload
@ -320,34 +321,46 @@ of the elements of LIST is performed as if by `pcase-let'.
(defun pcase--trivial-upat-p (upat) (defun pcase--trivial-upat-p (upat)
(and (symbolp upat) (not (memq upat pcase--dontcare-upats)))) (and (symbolp upat) (not (memq upat pcase--dontcare-upats))))
(defun pcase--expand (exp cases) (defun pcase-compile-patterns (exp cases)
;; (message "pid=%S (pcase--expand %S ...hash=%S)" "Compile the set of patterns in CASES.
;; (emacs-pid) exp (sxhash cases)) EXP is the expression that will be matched against the patterns.
CASES is a list of elements (PAT . CODEGEN)
where CODEGEN is a function that returns the code to use when
PAT matches. That code has to be in the form of a cons cell.
CODEGEN will be called with at least 2 arguments, VARVALS and COUNT.
VARVALS is a list of elements of the form (VAR VAL . RESERVED) where VAR
is a variable bound by the pattern and VAL is a duplicable expression
that returns the value this variable should be bound to.
If the pattern PAT uses `or', CODEGEN may be called multiple times,
in which case it may want to generate the code differently to avoid
a potential code explosion. For this reason the COUNT argument indicates
how many time this CODEGEN is called."
(macroexp-let2 macroexp-copyable-p val exp (macroexp-let2 macroexp-copyable-p val exp
(let* ((defs ()) (let* ((seen '())
(seen '()) (phcounter 0)
(main (main
(pcase--u (pcase--u
(mapcar (mapcar
(lambda (case) (lambda (case)
`(,(pcase--match val (pcase--macroexpand (car case))) `(,(pcase--match val (pcase--macroexpand (car case)))
,(lambda (vars) ,(lambda (vars)
(let ((prev (assq case seen)) (let ((prev (assq case seen)))
(code (cdr case)))
(unless prev (unless prev
;; Keep track of the cases that are used. ;; Keep track of the cases that are used.
(push (setq prev (list case)) seen)) (push (setq prev (list case)) seen))
(if (member code '(nil (nil))) nil ;; Put a counter in the cdr just so that not
;; Put `code' in the cdr just so that not all ;; all branches look identical (to avoid things
;; branches look identical (to avoid things like ;; like `macroexp--if' optimizing them too
;; `macroexp--if' optimizing them too optimistically). ;; optimistically).
(let ((ph (list 'pcase--placeholder code))) (let ((ph (cons 'pcase--placeholder
(setcdr prev (cons (cons vars ph) (cdr prev))) (setq phcounter (1+ phcounter)))))
ph)))))) (setcdr prev (cons (cons vars ph) (cdr prev)))
ph)))))
cases)))) cases))))
;; Take care of the place holders now. ;; Take care of the place holders now.
(dolist (branch seen) (dolist (branch seen)
(let ((code (cdar branch)) (let ((codegen (cdar branch))
(uses (cdr branch))) (uses (cdr branch)))
;; Find all the vars that are in scope (the union of the ;; Find all the vars that are in scope (the union of the
;; vars provided in each use case). ;; vars provided in each use case).
@ -358,48 +371,74 @@ of the elements of LIST is performed as if by `pcase-let'.
(if vi (if vi
(if (cddr v) (setcdr vi 'used)) (if (cddr v) (setcdr vi 'used))
(push (cons (car v) (cddr v)) allvarinfo)))))) (push (cons (car v) (cddr v)) allvarinfo))))))
(allvars (mapcar #'car allvarinfo)) (allvars (mapcar #'car allvarinfo)))
(ignores (mapcar (lambda (vi) (when (cdr vi) `(ignore ,(car vi)))) (dolist (use uses)
allvarinfo))) (let* ((vars (car use))
;; Since we use a tree-based pattern matching (varvals
;; technique, the leaves (the places that contain the (mapcar (lambda (v)
;; code to run once a pattern is matched) can get `(,v ,(cadr (assq v vars))
;; copied a very large number of times, so to avoid ,(cdr (assq v allvarinfo))))
;; code explosion, we need to keep track of how many allvars))
;; times we've used each leaf and move it (placeholder (cdr use))
;; to a separate function if that number is too high. (code (funcall codegen varvals (length uses))))
(if (or (null (cdr uses)) (pcase--small-branch-p code)) ;; (cl-assert (eq (car placeholder) 'pcase--placeholder))
(dolist (use uses) (setcar placeholder (car code))
(let ((vars (car use)) (setcdr placeholder (cdr code)))))))
(placeholder (cdr use)))
;; (cl-assert (eq (car placeholder) 'pcase--placeholder))
(setcar placeholder 'let)
(setcdr placeholder
`(,(mapcar (lambda (v) (list v (cadr (assq v vars))))
allvars)
;; Try and silence some of the most common
;; spurious "unused var" warnings.
,@ignores
,@code))))
;; Several occurrence of this non-small branch in the output.
(let ((bsym
(make-symbol (format "pcase-%d" (length defs)))))
(push `(,bsym (lambda ,allvars ,@ignores ,@code)) defs)
(dolist (use uses)
(let ((vars (car use))
(placeholder (cdr use)))
;; (cl-assert (eq (car placeholder) 'pcase--placeholder))
(setcar placeholder 'funcall)
(setcdr placeholder
`(,bsym
,@(mapcar (lambda (v) (cadr (assq v vars)))
allvars))))))))))
(dolist (case cases) (dolist (case cases)
(unless (or (assq case seen) (unless (or (assq case seen)
(memq (car case) pcase--dontwarn-upats)) (memq (car case) pcase--dontwarn-upats))
(message "pcase pattern %S shadowed by previous pcase pattern" (setq main
(car case)))) (macroexp-warn-and-return
(macroexp-let* defs main)))) (format "pcase pattern %S shadowed by previous pcase pattern"
(car case))
main))))
main)))
(defun pcase--expand (exp cases)
;; (message "pid=%S (pcase--expand %S ...hash=%S)"
;; (emacs-pid) exp (sxhash cases))
(let* ((defs ())
(codegen
(lambda (code)
(if (member code '(nil (nil) ('nil)))
(lambda (&rest _) ''nil)
(let ((bsym ()))
(lambda (varvals count &rest _)
(let* ((ignored-vars
(delq nil (mapcar (lambda (vv) (if (nth 2 vv) (car vv)))
varvals)))
(ignores (if ignored-vars
`((ignore . ,ignored-vars)))))
;; Since we use a tree-based pattern matching
;; technique, the leaves (the places that contain the
;; code to run once a pattern is matched) can get
;; copied a very large number of times, so to avoid
;; code explosion, we need to keep track of how many
;; times we've used each leaf and move it
;; to a separate function if that number is too high.
(if (or (< count 2) (pcase--small-branch-p code))
`(let ,(mapcar (lambda (vv) (list (car vv) (cadr vv)))
varvals)
;; Try and silence some of the most common
;; spurious "unused var" warnings.
,@ignores
,@code)
;; Several occurrence of this non-small branch in
;; the output.
(unless bsym
(setq bsym (make-symbol
(format "pcase-%d" (length defs))))
(push `(,bsym (lambda ,(mapcar #'car varvals)
,@ignores ,@code))
defs))
`(funcall ,bsym ,@(mapcar #'cadr varvals)))))))))
(main
(pcase-compile-patterns
exp
(mapcar (lambda (case)
(cons (car case) (funcall codegen (cdr case))))
cases))))
(macroexp-let* defs main)))
(defun pcase--macroexpand (pat) (defun pcase--macroexpand (pat)
"Expands all macro-patterns in PAT." "Expands all macro-patterns in PAT."