From 8ef122b4befc1236ee1ff316088d1c109b6b1a07 Mon Sep 17 00:00:00 2001 From: Noah Lavine Date: Wed, 15 Feb 2012 20:15:41 -0500 Subject: [PATCH] Add Identity Optimization * language/tree-il/peval.scm: add 'identities', which allow peval to prove that two things are equal without knowing their values. --- module/language/tree-il/peval.scm | 89 +++++++++++++++++++++++++++++++----- 1 files changed, 76 insertions(+), 13 deletions(-) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 9aac24c..e2fc16b 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -46,14 +46,14 @@ ;; First, some helpers. ;; -(define-syntax *logging* (identifier-syntax #f)) +;; (define-syntax *logging* (identifier-syntax #f)) ;; For efficiency we define *logging* to inline to #f, so that the call ;; to log* gets optimized out. If you want to log, uncomment these ;; lines: ;; -;; (define %logging #f) -;; (define-syntax *logging* (identifier-syntax %logging)) +(define %logging #f) +(define-syntax *logging* (identifier-syntax %logging)) ;; ;; Then you can change %logging at runtime. @@ -285,7 +285,8 @@ ;; (define-record-type (%make-operand var sym visit source visit-count residualize? - copyable? residual-value constant-value) + copyable? residual-value constant-value + identity identity-visit identifiable?) operand? (var operand-var) (sym operand-sym) @@ -295,18 +296,23 @@ (residualize? operand-residualize? set-operand-residualize?!) (copyable? operand-copyable? set-operand-copyable?!) (residual-value operand-residual-value %set-operand-residual-value!) - (constant-value operand-constant-value set-operand-constant-value!)) + (constant-value operand-constant-value set-operand-constant-value!) + (identity %operand-identity set-operand-identity!) + (identity-visit %operand-identity-visit) + (identifiable? operand-identifiable? set-operand-identifiable?!)) -(define* (make-operand var sym #:optional source visit) +(define* (make-operand var sym #:optional source visit id-visit) ;; Bind SYM to VAR, with value SOURCE. Bound operands are considered ;; copyable until we prove otherwise. If we have a source expression, ;; truncate it to one value. Copy propagation does not work on ;; multiply-valued expressions. (let ((source (and=> source truncate-values))) - (%make-operand var sym visit source 0 #f (and source #t) #f #f))) + (%make-operand var sym visit source 0 #f (and source #t) #f #f + #f id-visit #t))) -(define (make-bound-operands vars syms sources visit) - (map (lambda (x y z) (make-operand x y z visit)) vars syms sources)) +(define (make-bound-operands vars syms sources visit id-visit) + (map (lambda (x y z) (make-operand x y z visit id-visit)) + vars syms sources)) (define (make-unbound-operands vars syms) (map make-operand vars syms)) @@ -322,6 +328,15 @@ (else val)))) +(define (operand-identity op) + (and (operand-identifiable? op) + (or (operand-constant-value op) + (%operand-identity op)))) + +(define-record-type + (make-identity) + identity?) + (define* (visit-operand op counter ctx #:optional effort-limit size-limit) ;; Peval is O(N) in call sites of the source program. However, ;; visiting an operand can introduce new call sites. If we visit an @@ -348,6 +363,17 @@ (lambda () (set-operand-visit-count! op (1- (operand-visit-count op))))))) +(define (visit-operand-for-identity op) + (and (zero? (operand-visit-count op)) + (dynamic-wind + (lambda () + (set-operand-visit-count! op (1+ (operand-visit-count op)))) + (lambda () + (and (operand-source op) + ((%operand-identity-visit op) (operand-source op)))) + (lambda () + (set-operand-visit-count! op (1- (operand-visit-count op))))))) + ;; A helper for constant folding. ;; (define (types-check? primitive-name args) @@ -602,6 +628,28 @@ top-level bindings from ENV and return the resulting expression." (and (loop tag) (loop body) (loop handler))) (_ #f)))) + ;; return an identity for x, or #f if we can't + (define (get-identity x env) + (match x + (($ ) x) + (($ _ _ gensym) + (let ((op (cdr (vhash-assq gensym env)))) + (cond ((not (operand-identifiable? op)) #f) + ((var-set? (operand-var op)) + (set-operand-identifiable?! op #f) + #f) + ((operand-identity op) => identity) + ((visit-operand-for-identity op) => + (lambda (id) + (set-operand-identity! op id) + id)) + (else (set-operand-identity! op #f) + (set-operand-identifiable?! op #f) + #f)))) + (($ ) (make-identity)) + (($ ) (make-identity)) + (_ #f))) + (define (prune-bindings ops in-order? body counter ctx build-result) ;; This helper handles both `let' and `letrec'/`fix'. In the latter ;; cases we need to make sure that if referenced binding A needs @@ -832,7 +880,9 @@ top-level bindings from ENV and return the resulting expression." (new (fresh-gensyms vars)) (ops (make-bound-operands vars new vals (lambda (exp counter ctx) - (loop exp env counter ctx)))) + (loop exp env counter ctx)) + (lambda (exp) + (get-identity exp env)))) (env (fold extend-env env gensyms ops)) (body (loop body env counter ctx))) (cond @@ -861,9 +911,10 @@ top-level bindings from ENV and return the resulting expression." ;; an environment that includes the operands. (letrec* ((visit (lambda (exp counter ctx) (loop exp env* counter ctx))) + (id-visit (lambda (exp) (get-identity exp env))) (vars (map lookup-var gensyms)) (new (fresh-gensyms vars)) - (ops (make-bound-operands vars new vals visit)) + (ops (make-bound-operands vars new vals visit id-visit)) (env* (fold extend-env env gensyms ops)) (body* (visit body counter ctx))) (if (and (const? body*) (every constant-expression? vals)) @@ -878,9 +929,10 @@ top-level bindings from ENV and return the resulting expression." (($ src names gensyms vals body) (letrec* ((visit (lambda (exp counter ctx) (loop exp env* counter ctx))) + (id-visit (lambda (exp) (get-identity exp env))) (vars (map lookup-var gensyms)) (new (fresh-gensyms vars)) - (ops (make-bound-operands vars new vals visit)) + (ops (make-bound-operands vars new vals visit id-visit)) (env* (fold extend-env env gensyms ops)) (body* (visit body counter ctx))) (if (const? body*) @@ -1109,12 +1161,23 @@ top-level bindings from ENV and return the resulting expression." (($ src name args) (make-primcall src name (map for-value args))) + (($ src ($ t-src 'eq?) (a b)) + (log 'visit-eq? (list 'eq? a b)) + (let ((id-a (get-identity a env)) + (id-b (get-identity b env))) + (log 'id-a id-a 'id-b id-b 'eq? (eq? id-a id-b)) + (if (and id-a id-b) + (make-const #f (eq? id-a id-b)) + (make-primcall src 'eq? (list a b))))) + (($ src orig-proc orig-args) ;; todo: augment the global env with specialized functions (let ((proc (visit orig-proc 'operator))) (match proc (($ _ name) - (for-tail (make-primcall src name orig-args))) + (let ((rep (make-primcall src name orig-args))) + (log 'replacing-call exp rep) + (for-tail rep))) (($ _ _ ($ _ req opt #f #f inits gensyms body #f)) ;; Simple case: no rest, no keyword arguments. -- 1.7.6