procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* lisp/emacs-lisp/pcase.el (pcase--let*): New function.

Browse source 
(pcase-let*): Use it.  Use pcase--memoize to avoid repeated expansions.
(pcase--expand): Use macroexp-let².
This commit is contained in:
Stefan Monnier 2012-06-10 20:33:33 -04:00
parent cef5bb19dc
commit 82ad98e37d
2 changed files with 96 additions and 72 deletions
Download patch file Download diff file Expand all files Collapse all files

162
lisp/emacs-lisp/pcase.el
View file

@ -61,6 +61,8 @@
;; memoize previous macro expansions to try and avoid recomputing them
;; over and over again.
(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
(defconst pcase--dontcare-upats '(t _ dontcare))
@ -107,31 +109,49 @@ like `(,a . ,(pred (< a))) or, with more checks:
(if (and (equal exp (car data)) (equal cases (cadr data)))
;; We have the right expansion.
(cddr data)
;; (when (gethash (car cases) pcase--memoize-1)
;; (message "pcase-memoize failed because of weak key!!"))
;; (when (gethash (car cases) pcase--memoize-2)
;; (message "pcase-memoize failed because of eq test on %S"
;; (car cases)))
(when data
(message "pcase-memoize: equal first branch, yet different"))
(let ((expansion (pcase--expand exp cases)))
(puthash (car cases) (cons exp (cons cases expansion)) pcase--memoize)
(puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize)
;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-1)
;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
expansion))))
(defun pcase--let* (bindings body)
(cond
((null bindings) (macroexp-progn body))
((pcase--trivial-upat-p (caar bindings))
(macroexp-let* `(,(car bindings)) (pcase--let* (cdr bindings) body)))
(t
(let ((binding (pop bindings)))
(pcase--expand
(cadr binding)
`((,(car binding) ,(pcase--let* bindings body))
;; We can either signal an error here, or just use `dontcare' which
;; generates more efficient code. In practice, if we use `dontcare'
;; we will still often get an error and the few cases where we don't
;; do not matter that much, so it's a better choice.
(dontcare nil)))))))
;;;###autoload
(defmacro pcase-let* (bindings &rest body)
"Like `let*' but where you can use `pcase' patterns for bindings.
BODY should be an expression, and BINDINGS should be a list of bindings
of the form (UPAT EXP)."
(declare (indent 1)
(debug ((&rest &or (sexp &optional form) symbolp) body)))
(cond
((null bindings) (if (> (length body) 1) `(progn ,@body) (car body)))
((pcase--trivial-upat-p (caar bindings))
`(let (,(car bindings)) (pcase-let* ,(cdr bindings) ,@body)))
(t
`(pcase ,(cadr (car bindings))
(,(caar bindings) (pcase-let* ,(cdr bindings) ,@body))
;; We can either signal an error here, or just use `dontcare' which
;; generates more efficient code. In practice, if we use `dontcare' we
;; will still often get an error and the few cases where we don't do not
;; matter that much, so it's a better choice.
(dontcare nil)))))
(debug ((&rest (sexp &optional form)) body)))
(let ((cached (gethash bindings pcase--memoize)))
;; cached = (BODY . EXPANSION)
(if (equal (car cached) body)
(cdr cached)
(let ((expansion (pcase--let* bindings body)))
(puthash bindings (cons body expansion) pcase--memoize)
expansion))))
;;;###autoload
(defmacro pcase-let (bindings &rest body)
@ -169,64 +189,62 @@ of the form (UPAT EXP)."
(defun pcase--expand (exp cases)
;; (message "pid=%S (pcase--expand %S ...hash=%S)"
;; (emacs-pid) exp (sxhash cases))
(let* ((defs (if (symbolp exp) '()
(let ((sym (make-symbol "x")))
(prog1 `((,sym ,exp)) (setq exp sym)))))
(seen '())
(codegen
(lambda (code vars)
(let ((prev (assq code seen)))
(if (not prev)
(let ((res (pcase-codegen code vars)))
(push (list code vars res) seen)
res)
;; 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.
;;
;; We've already used this branch. So it is shared.
(let* ((code (car prev)) (cdrprev (cdr prev))
(prevvars (car cdrprev)) (cddrprev (cdr cdrprev))
(res (car cddrprev)))
(unless (symbolp res)
;; This is the first repeat, so we have to move
;; the branch to a separate function.
(let ((bsym
(make-symbol (format "pcase-%d" (length defs)))))
(push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) defs)
(setcar res 'funcall)
(setcdr res (cons bsym (mapcar #'cdr prevvars)))
(setcar (cddr prev) bsym)
(setq res bsym)))
(setq vars (copy-sequence vars))
(let ((args (mapcar (lambda (pa)
(let ((v (assq (car pa) vars)))
(setq vars (delq v vars))
(cdr v)))
prevvars)))
;; If some of `vars' were not found in `prevvars', that's
;; OK it just means those vars aren't present in all
;; branches, so they can be used within the pattern
;; (e.g. by a `guard/let/pred') but not in the branch.
;; FIXME: But if some of `prevvars' are not in `vars' we
;; should remove them from `prevvars'!
`(funcall ,res ,@args)))))))
(main
(pcase--u
(mapcar (lambda (case)
`((match ,exp . ,(car case))
,(apply-partially
(if (pcase--small-branch-p (cdr case))
;; Don't bother sharing multiple
;; occurrences of this leaf since it's small.
#'pcase-codegen codegen)
(cdr case))))
cases))))
(if (null defs) main
(macroexp-let² macroexp-copyable-p val exp
(let* ((defs ())
(seen '())
(codegen
(lambda (code vars)
(let ((prev (assq code seen)))
(if (not prev)
(let ((res (pcase-codegen code vars)))
(push (list code vars res) seen)
res)
;; 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.
;;
;; We've already used this branch. So it is shared.
(let* ((code (car prev)) (cdrprev (cdr prev))
(prevvars (car cdrprev)) (cddrprev (cdr cdrprev))
(res (car cddrprev)))
(unless (symbolp res)
;; This is the first repeat, so we have to move
;; the branch to a separate function.
(let ((bsym
(make-symbol (format "pcase-%d" (length defs)))))
(push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) defs)
(setcar res 'funcall)
(setcdr res (cons bsym (mapcar #'cdr prevvars)))
(setcar (cddr prev) bsym)
(setq res bsym)))
(setq vars (copy-sequence vars))
(let ((args (mapcar (lambda (pa)
(let ((v (assq (car pa) vars)))
(setq vars (delq v vars))
(cdr v)))
prevvars)))
;; If some of `vars' were not found in `prevvars', that's
;; OK it just means those vars aren't present in all
;; branches, so they can be used within the pattern
;; (e.g. by a `guard/let/pred') but not in the branch.
;; FIXME: But if some of `prevvars' are not in `vars' we
;; should remove them from `prevvars'!
`(funcall ,res ,@args)))))))
(main
(pcase--u
(mapcar (lambda (case)
`((match ,val . ,(car case))
,(apply-partially
(if (pcase--small-branch-p (cdr case))
;; Don't bother sharing multiple
;; occurrences of this leaf since it's small.
#'pcase-codegen codegen)
(cdr case))))
cases))))
(macroexp-let* defs main))))
(defun pcase-codegen (code vars)