* lisp/emacs-lisp/pcase.el (pcase--if): Try to invert test to reduce depth.

(pcase-mutually-exclusive-predicates): New var.
(pcase--split-consp, pcase--split-pred): Use it.
(pcase--split-equal, pcase--split-member): When splitting against
a pure predicate, run it to know the outcome.
(pcase--u1): Mark vars that are actually used.
(pcase--q1): Avoid introducing unused vars.

2 files changed, 97 insertions, 14 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index d9f4c3c3ea2..c2731530e57 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,13 @@
+2011-02-27  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * emacs-lisp/pcase.el (pcase--if): Try to invert test to reduce depth.
+        (pcase-mutually-exclusive-predicates): New var.
+        (pcase--split-consp, pcase--split-pred): Use it.
+        (pcase--split-equal, pcase--split-member): When splitting against
+        a pure predicate, run it to know the outcome.
+        (pcase--u1): Mark vars that are actually used.
+        (pcase--q1): Avoid introducing unused vars.
+
 2011-02-27  Jay Belanger  <jay.p.belanger@gmail.com>
 
         * calc/calc-ext.el (calc-init-extensions):
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 3179672a3ec..0d5fd99db5d 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -32,6 +32,14 @@
 ;;   could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)).
 ;;   But better would be if we could define new ways to match by having the
 ;;   extension provide its own `pcase--split-<foo>' thingy.
+;; - provide something like (setq VAR) so a var can be set rather than
+;;   let-bound.
+;; - provide a way to fallthrough to other cases.
+;; - try and be more clever to reduce the size of the decision tree, and
+;;   to reduce the number of leafs that need to be turned into function:
+;;   - first, do the tests shared by all remaining branches (it will have
+;;     to be performed anyway, so better so it first so it's shared).
+;;   - then choose the test that discriminates more (?).
 ;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to
 ;;   generate a lex-style DFA to decide whether to run E1 or E2.
 
@@ -209,6 +217,7 @@ of the form (UPAT EXP)."
 (defun pcase--if (test then else)
   (cond
    ((eq else :pcase--dontcare) then)
+   ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
    ((eq (car-safe else) 'if)
     (if (equal test (nth 1 else))
         ;; Doing a test a second time: get rid of the redundancy.
@@ -223,6 +232,8 @@ of the form (UPAT EXP)."
     `(cond (,test ,then)
            ;; Doing a test a second time: get rid of the redundancy, as above.
            ,@(remove (assoc test else) (cdr else))))
+   ;; Invert the test if that lets us reduce the depth of the tree.
+   ((memq (car-safe then) '(if cond)) (pcase--if `(not ,test) else then))
    (t `(if ,test ,then ,else))))
 
 (defun pcase--upat (qpattern)
@@ -264,6 +275,22 @@ MATCH is the pattern that needs to be matched, of the form:
 (defun pcase--and (match matches)
   (if matches `(and ,match ,@matches) match))
 
+(defconst pcase-mutually-exclusive-predicates
+  '((symbolp . integerp)
+    (symbolp . numberp)
+    (symbolp . consp)
+    (symbolp . arrayp)
+    (symbolp . stringp)
+    (integerp . consp)
+    (integerp . arrayp)
+    (integerp . stringp)
+    (numberp . consp)
+    (numberp . arrayp)
+    (numberp . stringp)
+    (consp . arrayp)
+    (consp . stringp)
+    (arrayp . stringp)))
+
 (defun pcase--split-match (sym splitter match)
   (case (car match)
     ((match)
@@ -324,8 +351,14 @@ MATCH is the pattern that needs to be matched, of the form:
       (cons `(and (match ,syma . ,(pcase--upat (car qpat)))
                   (match ,symd . ,(pcase--upat (cdr qpat))))
             :pcase--fail)))
-   ;; A QPattern but not for a cons, can only go the `else' side.
-   ((eq (car-safe pat) '\`) (cons :pcase--fail nil))))
+   ;; A QPattern but not for a cons, can only go to the `else' side.
+   ((eq (car-safe pat) '\`) (cons :pcase--fail nil))
+   ((and (eq (car-safe pat) 'pred)
+         (or (member (cons 'consp (cadr pat))
+                     pcase-mutually-exclusive-predicates)
+             (member (cons (cadr pat) 'consp)
+                     pcase-mutually-exclusive-predicates)))
+    (cons :pcase--fail nil))))
 
 (defun pcase--split-equal (elem pat)
   (cond
@@ -337,7 +370,12 @@ MATCH is the pattern that needs to be matched, of the form:
          ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
          ;;     (consp (cadr pat)))
          )
-    (cons :pcase--fail nil))))
+    (cons :pcase--fail nil))
+   ((and (eq (car-safe pat) 'pred)
+         (symbolp (cadr pat))
+         (get (cadr pat) 'side-effect-free)
+         (funcall (cadr pat) elem))
+    (cons :pcase--succeed nil))))
 
 (defun pcase--split-member (elems pat)
   ;; Based on pcase--split-equal.
@@ -354,13 +392,39 @@ MATCH is the pattern that needs to be matched, of the form:
          ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
          ;;     (consp (cadr pat)))
          )
-    (cons :pcase--fail nil))))
+    (cons :pcase--fail nil))
+   ((and (eq (car-safe pat) 'pred)
+         (symbolp (cadr pat))
+         (get (cadr pat) 'side-effect-free)
+         (let ((p (cadr pat)) (all t))
+           (dolist (elem elems)
+             (unless (funcall p elem) (setq all nil)))
+           all))
+    (cons :pcase--succeed nil))))
 
 (defun pcase--split-pred (upat pat)
   ;; FIXME: For predicates like (pred (> a)), two such predicates may
   ;; actually refer to different variables `a'.
-  (if (equal upat pat)
-      (cons :pcase--succeed :pcase--fail)))
+  (cond
+   ((equal upat pat) (cons :pcase--succeed :pcase--fail))
+   ((and (eq 'pred (car upat))
+         (eq 'pred (car-safe pat))
+         (or (member (cons (cadr upat) (cadr pat))
+                     pcase-mutually-exclusive-predicates)
+             (member (cons (cadr pat) (cadr upat))
+                     pcase-mutually-exclusive-predicates)))
+    (cons :pcase--fail nil))
+   ;; ((and (eq 'pred (car upat))
+   ;;       (eq '\` (car-safe pat))
+   ;;       (symbolp (cadr upat))
+   ;;       (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
+   ;;       (get (cadr upat) 'side-effect-free)
+   ;;       (progn (message "Trying predicate %S" (cadr upat))
+   ;;              (ignore-errors
+   ;;                (funcall (cadr upat) (cadr pat)))))
+   ;;  (message "Simplify pred %S against %S" upat pat)
+   ;;  (cons nil :pcase--fail))
+   ))
 
 (defun pcase--fgrep (vars sexp)
   "Check which of the symbols VARS appear in SEXP."
@@ -433,6 +497,7 @@ and otherwise defers to REST which is a list of branches of the form
        ((eq upat 'dontcare) :pcase--dontcare)
        ((functionp upat)  (error "Feature removed, use (pred %s)" upat))
        ((memq (car-safe upat) '(guard pred))
+        (if (eq (car upat) 'pred) (put sym 'pcase-used t))
         (destructuring-bind (then-rest &rest else-rest)
             (pcase--split-rest
              sym (apply-partially #'pcase--split-pred upat) rest)
@@ -459,6 +524,7 @@ and otherwise defers to REST which is a list of branches of the form
                      (pcase--u1 matches code vars then-rest)
                      (pcase--u else-rest))))
        ((symbolp upat)
+        (put sym 'pcase-used t)
         (if (not (assq upat vars))
             (pcase--u1 matches code (cons (cons upat sym) vars) rest)
           ;; Non-linear pattern.  Turn it into an `eq' test.
@@ -466,6 +532,7 @@ and otherwise defers to REST which is a list of branches of the form
                            matches)
                      code vars rest)))
        ((eq (car-safe upat) '\`)
+        (put sym 'pcase-used t)
         (pcase--q1 sym (cadr upat) matches code vars rest))
        ((eq (car-safe upat) 'or)
         (let ((all (> (length (cdr upat)) 1))
@@ -539,14 +606,20 @@ and if not, defers to REST which is a list of branches of the form
           (pcase--split-rest sym
                              (apply-partially #'pcase--split-consp syma symd)
                              rest)
-        (pcase--if `(consp ,sym)
-                   `(let ((,syma (car ,sym))
-                          (,symd (cdr ,sym)))
-                      ,(pcase--u1 `((match ,syma . ,(pcase--upat (car qpat)))
-                                    (match ,symd . ,(pcase--upat (cdr qpat)))
-                                    ,@matches)
-                                  code vars then-rest))
-                   (pcase--u else-rest)))))
+        (let ((then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat)))
+                                      (match ,symd . ,(pcase--upat (cdr qpat)))
+                                      ,@matches)
+                                    code vars then-rest)))
+          (pcase--if
+           `(consp ,sym)
+           ;; We want to be careful to only add bindings that are used.
+           ;; The byte-compiler could do that for us, but it would have to pay
+           ;; attention to the `consp' test in order to figure out that car/cdr
+           ;; can't signal errors and our byte-compiler is not that clever.
+           `(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
+                  ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
+              ,then-body)
+           (pcase--u else-rest))))))
    ((or (integerp qpat) (symbolp qpat) (stringp qpat))
     (destructuring-bind (then-rest &rest else-rest)
         (pcase--split-rest sym (apply-partially 'pcase--split-equal qpat) rest)