(expressions-equal? exp exp*))
(_ #f)))
- (define (unroll db from to)
- (or (<= from to)
- (match (vlist-ref db (1- from))
+ (define (unroll db base n)
+ (or (zero? n)
+ (match (vlist-ref db base)
(('lambda . h*)
;; See note in find-dominating-expression.
(and (not (depends-on-effects? effects &all-effects))
- (unroll db (1- from) to)))
+ (unroll db (1+ base) (1- n))))
((#(exp* effects* ctx*) . h*)
(and (effects-commute? effects effects*)
- (unroll db (1- from) to))))))
+ (unroll db (1+ base) (1- n)))))))
(let ((h (hash-expression exp)))
(and (effect-free? (exclude-effects effects &type-check))
(vhash-assoc exp env entry-matches? (hasher h))
- (let ((env-len (vlist-length env)))
- (let lp ((n 0) (db-len (vlist-length db)))
+ (let ((env-len (vlist-length env))
+ (db-len (vlist-length db)))
+ (let lp ((n 0) (m 0))
(and (< n env-len)
(match (vlist-ref env n)
((#(exp* name sym db-len*) . h*)
- (and (unroll db db-len db-len*)
+ (and (unroll db m (- db-len db-len*))
(if (and (= h h*) (expressions-equal? exp* exp))
(make-lexical-ref (tree-il-src exp) name sym)
- (lp (1+ n) db-len*)))))))))))
+ (lp (1+ n) (- db-len db-len*))))))))))))
(define (intersection db+ db-)
(vhash-fold-right
(logior &zero-values
&allocation)))
(has-dominating-effect? exp effects db)))
- (log 'elide ctx (unparse-tree-il exp))
- (values (make-void #f) db*))
+ (cond
+ ((void? exp)
+ (values exp db*))
+ (else
+ (log 'elide ctx (unparse-tree-il exp))
+ (values (make-void #f) db*))))
((and (boolean-valued-expression? exp ctx)
(find-dominating-test exp effects db))
=> (lambda (exp)
(apply (primitive struct-ref) (lexical x _) (const 1))
(apply (primitive 'throw) (const 'foo))))
(apply (primitive +) (lexical z _)
- (apply (primitive struct-ref) (lexical x _) (const 2)))))))))
+ (apply (primitive struct-ref) (lexical x _) (const 2))))))))
+
+ ;; Replacing named expressions with lexicals.
+ (pass-if-cse
+ (let ((x (car y)))
+ (cons x (car y)))
+ (let (x) (_) ((apply (primitive car) (toplevel y)))
+ (apply (primitive cons) (lexical x _) (lexical x _)))))