peval support for memq and memv

* module/language/tree-il/peval.scm (peval): Add special handlers for
  memq and memv, as inline.scm used to have.  This is important for
  `case' clauses.  It is very ugly, though.

* test-suite/tests/tree-il.test ("partial evaluation"): Add tests.

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 2ef77ae..8091e16 100644 (file)
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -369,6 +369,9 @@ top-level bindings from ENV and return the resulting expression."
   ;;
   (define store (build-var-table exp))
 
+  (define (record-new-temporary! name sym refcount)
+    (set! store (vhash-consq sym (make-var name sym refcount #f) store)))
+
   (define (lookup-var sym)
     (let ((v (vhash-assq sym store)))
       (if v (cdr v) (error "unbound var" sym (vlist->list store)))))
@@ -952,6 +955,49 @@ top-level bindings from ENV and return the resulting expression."
                (for-tail (make-const src head)))
               (('cdr ($ <const> src (head . tail)))
                (for-tail (make-const src tail)))
+              (((or 'memq 'memv) k ($ <const> _ (elts ...)))
+               ;; FIXME: factor 
+               (case ctx
+                 ((effect)
+                  (for-tail
+                   (make-sequence src (list k (make-void #f)))))
+                 ((test)
+                  (cond
+                   ((const? k)
+                    ;; A shortcut.  The `else' case would handle it, but
+                    ;; this way is faster.
+                    (let ((member (case name ((memq) memq) ((memv) memv))))
+                      (make-const #f (and (member (const-exp k) elts) #t))))
+                   ((null? elts)
+                    (for-tail
+                     (make-sequence src (list k (make-const #f #f)))))
+                   (else
+                    (let ((t (gensym "t "))
+                          (eq (if (eq? name 'memq) 'eq? 'eqv?)))
+                      (record-new-temporary! 't t (length elts))
+                      (for-tail
+                       (make-let
+                        src (list 't) (list t) (list k)
+                        (let lp ((elts elts))
+                          (define test
+                            (make-application
+                             #f (make-primitive-ref #f eq)
+                             (list (make-lexical-ref #f 't t)
+                                   (make-const #f (car elts)))))
+                          (if (null? (cdr elts))
+                              test
+                              (make-conditional src test
+                                                (make-const #f #t)
+                                                (lp (cdr elts)))))))))))
+                 (else
+                  (cond
+                   ((const? k)
+                    (let ((member (case name ((memq) memq) ((memv) memv))))
+                      (make-const #f (member (const-exp k) elts))))
+                   ((null? elts)
+                    (for-tail (make-sequence src (list k (make-const #f #f)))))
+                   (else
+                    (make-application src proc (list k (make-const #f elts))))))))
               ((_ . args)
                (make-application src proc args))))
            (($ <primitive-ref> _ (? effect-free-primitive? name))

diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 4b17cb5..789e8fd 100644 (file)
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1074,6 +1074,43 @@
       (and (even? 4) (odd? 7)))
     (const #t))
 
+  (pass-if-peval
+    ;; Memv with constants.
+    (memv 1 '(3 2 1))
+    (const '(1)))
+
+  (pass-if-peval
+    ;; Memv with non-constant list.  It could fold but doesn't
+    ;; currently.
+    (memv 1 (list 3 2 1))
+    (apply (primitive memv)
+           (const 1)
+           (apply (primitive list) (const 3) (const 2) (const 1))))
+
+  (pass-if-peval
+    ;; Memv with non-constant key, constant list, test context
+    (case foo
+      ((3 2 1) 'a)
+      (else 'b))
+    (if (let (t) (_) ((toplevel foo))
+             (if (apply (primitive eqv?) (lexical t _) (const 3))
+                 (const #t)
+                 (if (apply (primitive eqv?) (lexical t _) (const 2))
+                     (const #t)
+                     (apply (primitive eqv?) (lexical t _) (const 1)))))
+        (const a)
+        (const b)))
+
+  (pass-if-peval
+    ;; Memv with non-constant key, empty list, test context.  Currently
+    ;; doesn't fold entirely.
+    (case foo
+      (() 'a)
+      (else 'b))
+    (if (begin (toplevel foo) (const #f))
+        (const a)
+        (const b)))
+
   ;;
   ;; Below are cases where constant propagation should bail out.
   ;;