dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

peval support for memq and memv

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2011-10-10 14:42:40 +02:00
commit 4bf9e92875
2 changed files with 83 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

46
module/language/tree-il/peval.scm
View file

@ -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))

37
test-suite/tests/tree-il.test
View file

@ -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.
;;