From 937b6c18bd6c4806eb1e4c8764db56b314c09056 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 19 Mar 2021 17:42:22 -0400 Subject: [PATCH] * lisp/emacs-lisp/pcase.el (pcase-compile-patterns): New function (bug#47261) Extracted from `pcase--expand`. (pcase--expand): Use it. --- etc/NEWS | 3 + lisp/emacs-lisp/pcase.el | 147 +++++++++++++++++++++++++-------------- 2 files changed, 96 insertions(+), 54 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 6dda3423c17..fb8fa322a12 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -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 in better code. +--- +*** New function 'pcase-compile-patterns' to write other macros. + +++ ** profiler.el The results displayed by 'profiler-report' now have the usage figures diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 5342a0179d9..006517db759 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -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--expand ;; 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))))))) ;;;###autoload @@ -320,34 +321,46 @@ of the elements of LIST is performed as if by `pcase-let'. (defun pcase--trivial-upat-p (upat) (and (symbolp upat) (not (memq upat pcase--dontcare-upats)))) -(defun pcase--expand (exp cases) - ;; (message "pid=%S (pcase--expand %S ...hash=%S)" - ;; (emacs-pid) exp (sxhash cases)) +(defun pcase-compile-patterns (exp cases) + "Compile the set of patterns in 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 - (let* ((defs ()) - (seen '()) + (let* ((seen '()) + (phcounter 0) (main (pcase--u (mapcar (lambda (case) `(,(pcase--match val (pcase--macroexpand (car case))) ,(lambda (vars) - (let ((prev (assq case seen)) - (code (cdr case))) + (let ((prev (assq case seen))) (unless prev ;; Keep track of the cases that are used. (push (setq prev (list case)) seen)) - (if (member code '(nil (nil))) nil - ;; Put `code' in the cdr just so that not all - ;; branches look identical (to avoid things like - ;; `macroexp--if' optimizing them too optimistically). - (let ((ph (list 'pcase--placeholder code))) - (setcdr prev (cons (cons vars ph) (cdr prev))) - ph)))))) + ;; Put a counter in the cdr just so that not + ;; all branches look identical (to avoid things + ;; like `macroexp--if' optimizing them too + ;; optimistically). + (let ((ph (cons 'pcase--placeholder + (setq phcounter (1+ phcounter))))) + (setcdr prev (cons (cons vars ph) (cdr prev))) + ph))))) cases)))) ;; Take care of the place holders now. (dolist (branch seen) - (let ((code (cdar branch)) + (let ((codegen (cdar branch)) (uses (cdr branch))) ;; Find all the vars that are in scope (the union of the ;; 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 (cddr v) (setcdr vi 'used)) (push (cons (car v) (cddr v)) allvarinfo)))))) - (allvars (mapcar #'car allvarinfo)) - (ignores (mapcar (lambda (vi) (when (cdr vi) `(ignore ,(car vi)))) - allvarinfo))) - ;; 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 (null (cdr uses)) (pcase--small-branch-p code)) - (dolist (use uses) - (let ((vars (car use)) - (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)))))))))) + (allvars (mapcar #'car allvarinfo))) + (dolist (use uses) + (let* ((vars (car use)) + (varvals + (mapcar (lambda (v) + `(,v ,(cadr (assq v vars)) + ,(cdr (assq v allvarinfo)))) + allvars)) + (placeholder (cdr use)) + (code (funcall codegen varvals (length uses)))) + ;; (cl-assert (eq (car placeholder) 'pcase--placeholder)) + (setcar placeholder (car code)) + (setcdr placeholder (cdr code))))))) (dolist (case cases) (unless (or (assq case seen) (memq (car case) pcase--dontwarn-upats)) - (message "pcase pattern %S shadowed by previous pcase pattern" - (car case)))) - (macroexp-let* defs main)))) + (setq main + (macroexp-warn-and-return + (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) "Expands all macro-patterns in PAT." -- 2.39.2