(($ <const> _ (? boolean?)) #t)
(_ (eq? ctx 'test))))
+(define (singly-valued-expression? x ctx)
+ (match x
+ (($ <const>) #t)
+ (($ <lexical-ref>) #t)
+ (($ <void>) #t)
+ (($ <lexical-ref>) #t)
+ (($ <primitive-ref>) #t)
+ (($ <module-ref>) #t)
+ (($ <toplevel-ref>) #t)
+ (($ <primcall> _ (? singly-valued-primitive?)) #t)
+ (($ <primcall> _ 'values (val)) #t)
+ (($ <lambda>) #t)
+ (_ (eq? ctx 'value))))
+
(define* (cse exp)
"Eliminate common subexpressions in EXP."
(lambda (sym)
(vhash-assq sym table))))
- (define compute-effects
+ (define %compute-effects
(make-effects-analyzer assigned-lexical?))
(define (negate exp ctx)
(make-primcall #f 'not (list exp)))))
- (define (bailout? exp)
- (causes-effects? (compute-effects exp) &definite-bailout))
-
- (define (struct-nfields x)
- (/ (string-length (symbol->string (struct-layout x))) 2))
-
- (define hash-bits (logcount most-positive-fixnum))
- (define hash-depth 4)
- (define hash-width 3)
- (define (hash-expression exp)
- (define (hash-exp exp depth)
- (define (rotate x bits)
- (logior (ash x (- bits))
- (ash (logand x (1- (ash 1 bits))) (- hash-bits bits))))
- (define (mix h1 h2)
- (logxor h1 (rotate h2 8)))
- (define (hash-struct s)
- (let ((len (struct-nfields s))
- (h (hashq (struct-vtable s) most-positive-fixnum)))
- (if (zero? depth)
- h
- (let lp ((i (max (- len hash-width) 1)) (h h))
- (if (< i len)
- (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h))
- h)))))
- (define (hash-list l)
- (let ((h (hashq 'list most-positive-fixnum)))
- (if (zero? depth)
- h
- (let lp ((l l) (width 0) (h h))
- (if (< width hash-width)
- (lp (cdr l) (1+ width)
- (mix (hash-exp (car l) (1+ depth)) h))
- h)))))
- (cond
- ((struct? exp) (hash-struct exp))
- ((list? exp) (hash-list exp))
- (else (hash exp most-positive-fixnum))))
- (hash-exp exp 0))
-
- (define (expressions-equal? a b)
- (cond
- ((struct? a)
- (and (struct? b)
- (eq? (struct-vtable a) (struct-vtable b))
- ;; Assume that all structs are tree-il, so we skip over the
- ;; src slot.
- (let lp ((n (1- (struct-nfields a))))
- (or (zero? n)
- (and (expressions-equal? (struct-ref a n) (struct-ref b n))
- (lp (1- n)))))))
- ((pair? a)
- (and (pair? b)
- (expressions-equal? (car a) (car b))
- (expressions-equal? (cdr a) (cdr b))))
- (else
- (equal? a b))))
-
(define (hasher n)
(lambda (x size) (modulo n size)))
(define (add-to-db exp effects ctx db)
(let ((v (vector exp effects ctx))
- (h (hash-expression exp)))
+ (h (tree-il-hash exp)))
(vhash-cons v h db (hasher h))))
(define (control-flow-boundary db)
(define (entry-matches? v1 v2)
(match (if (vector? v1) v1 v2)
(#(exp* effects* ctx*)
- (and (expressions-equal? exp exp*)
+ (and (tree-il=? exp exp*)
(or (not ctx) (eq? ctx* ctx))))
(_ #f)))
(let ((len (vlist-length db))
- (h (hash-expression exp)))
+ (h (tree-il-hash exp)))
(and (vhash-assoc #t db entry-matches? (hasher h))
(let lp ((n 0))
(and (< n len)
(unparse-tree-il exp*) effects* ctx*)
(or (and (= h h*)
(or (not ctx) (eq? ctx ctx*))
- (expressions-equal? exp exp*))
+ (tree-il=? exp exp*))
(and (effects-commute? effects effects*)
(lp (1+ n)))))))))))
(define (add-to-env exp name sym db env)
(let* ((v (vector exp name sym (vlist-length db)))
- (h (hash-expression exp)))
+ (h (tree-il-hash exp)))
(vhash-cons v h env (hasher h))))
(define (augment-env env names syms exps db)
(define (entry-matches? v1 v2)
(match (if (vector? v1) v1 v2)
(#(exp* name sym db)
- (expressions-equal? exp exp*))
+ (tree-il=? exp exp*))
(_ #f)))
(define (unroll db base n)
(and (effects-commute? effects effects*)
(unroll db (1+ base) (1- n)))))))
- (let ((h (hash-expression exp)))
+ (let ((h (tree-il-hash exp)))
(and (effect-free? (exclude-effects effects &type-check))
(vhash-assoc exp env entry-matches? (hasher h))
(let ((env-len (vlist-length env))
(match (vlist-ref env n)
((#(exp* name sym db-len*) . h*)
(and (unroll db m (- db-len db-len*))
- (if (and (= h h*) (expressions-equal? exp* exp))
+ (if (and (= h h*) (tree-il=? exp* exp))
(make-lexical-ref (tree-il-src exp) name sym)
(lp (1+ n) (- db-len db-len*))))))))))))
+ (define (lookup-lexical sym env)
+ (let ((env-len (vlist-length env)))
+ (let lp ((n 0))
+ (and (< n env-len)
+ (match (vlist-ref env n)
+ ((#(exp _ sym* _) . _)
+ (if (eq? sym sym*)
+ exp
+ (lp (1+ n)))))))))
+
(define (intersection db+ db-)
(vhash-fold-right
(lambda (k h out)
(lp (cdr in) (cons x out) (concat db** db*))))
(values (reverse out) db*))))
+ (define (compute-effects exp)
+ (%compute-effects exp (lambda (sym) (lookup-lexical sym env))))
+
+ (define (bailout? exp)
+ (causes-effects? (compute-effects exp) &definite-bailout))
+
(define (return exp db*)
(let ((effects (compute-effects exp)))
(cond
=> (lambda (exp)
(log 'propagate-test ctx (unparse-tree-il exp))
(values exp db*)))
- ((and (eq? ctx 'value)
+ ((and (singly-valued-expression? exp ctx)
(find-dominating-lexical exp effects env db))
=> (lambda (exp)
(log 'propagate-value ctx (unparse-tree-il exp))
HCoop / bpt / guile.git / blobdiff