compiler: improve code for and/or.

Squeeze the constant and unreachable cases out of (and ...)
and (or ...) forms, producing a more streamlined translation.

This is the first appearance of structural pattern matching in
the compiler!

* share/txr/stdlib/compiler.tl (compiler compile): Handle and
using new expand-and function, which translates it to if
forms. Handle or via the renamed method comp-or.
(compiler comp-and-or): Renamed to comp-or, since it handles
only or. All the switching between or/and is eliminated.
The or form is first reduced using simplify-or.
We retain this function because one case in cond relies on or;
or is a useful primitive because (or a b) evaluates a only
once; whereas (if a a b) requires common-subexpression
elimination to generate the same code as (or a b).
(true-const-p, expand-and, flatten-or, reduce-or,
simplify-or): New functions.

1 files changed, 36 insertions, 9 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 123c179f..f62f5fb1 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -309,8 +309,8 @@
               (sys:for-op me.(comp-for oreg env form))
               (sys:each-op me.(compile oreg env (expand-each form env)))
               ((progn eval-only compile-only) me.(comp-progn oreg env (cdr form)))
-              (and me.(comp-and-or oreg env form))
-              (or me.(comp-and-or oreg env form))
+              (and me.(compile oreg env (expand-and form)))
+              (or me.(comp-or oreg env form))
               (prog1 me.(comp-prog1 oreg env form))
               (sys:quasi me.(comp-quasi oreg env form))
               (dohash me.(compile oreg env (expand-dohash form)))
@@ -960,15 +960,14 @@
     me.(free-treg oreg-discard)
     (new (frag (if lastfrag lastfrag.oreg ^(t 0)) code fvars ffuns))))
 
-(defmeth compiler comp-and-or (me oreg env form)
-  (tree-case form
-    ((op) me.(compile oreg env (if (eq op 'and) t)))
+(defmeth compiler comp-or (me oreg env form)
+  (tree-case (simplify-or form)
+    ((op) me.(compile oreg env nil))
     ((op arg) me.(compile oreg env arg))
     ((op . args)
      (let* (ffuns fvars
             (nargs (len args))
             lastfrag
-            (is-and (eq op 'and))
             (lout (gensym "l"))
             (treg me.(maybe-alloc-treg oreg))
             (code (build
@@ -981,9 +980,7 @@
                           (pend frag.code
                                 (maybe-mov treg frag.oreg))
                           (unless islast
-                            (add (if is-and
-                                   ^(if ,treg ,lout)
-                                   ^(ifq ,treg ,nil ,lout))))
+                            (add ^(ifq ,treg ,nil ,lout)))
                           (set fvars (uni fvars frag.fvars))
                           (set ffuns (uni ffuns frag.ffuns))))))))
        me.(maybe-free-treg treg oreg)
@@ -1277,6 +1274,36 @@
   (if (nequal to-reg from-reg)
     ^((mov ,to-reg ,from-reg))))
 
+(defun true-const-p (arg)
+  (and arg (constantp arg)))
+
+(defun expand-and (form)
+  (match-case form
+    ((and) t)
+    ((and @(true-const-p) . @rest) (expand-and ^(and ,*rest)))
+    ((and nil . @rest) nil)
+    ((and @a) a)
+    ((and @a @b) ^(if ,a ,b))
+    ((and @a . @rest) (expand-and ^(and ,a ,(expand-and ^(and ,*rest)))))
+    (@else else)))
+
+(defun flatten-or (form)
+  (match-case form
+    ((or . @args) ^(or ,*[mappend [chain flatten-or cdr] args]))
+    (@else ^(or ,else))))
+
+(defun reduce-or (form)
+  (match-case form
+    ((or) form)
+    ((or @a) form)
+    ((or nil . @rest) (reduce-or ^(or ,*rest)))
+    ((or @(true-const-p c) . @rest) ^(or ,c))
+    ((or @a . @rest) ^(or ,a ,*(cdr (reduce-or ^(or ,*rest)))))
+    (@else else)))
+
+(defun simplify-or (form)
+  (reduce-or (flatten-or form)))
+
 (defun expand-quasi-mods (obj mods : form)
   (let (plist num sep rng-ix scalar-ix-p flex gens)
     (flet ((get-sym (exp)