Sunday 21 December 2008

Common Subexpression Elimination


;; My example of when mutation is a useful tool that simplifies things.

(define (identity i) i)
(define (concat xs) (apply append xs))
(define (concat-map f x) (concat (map f x)))
(define (sort by xs)
(define (insert by x xs)
(if (null? xs)
(list x)
(if (< (by x) (by (car xs)))
(cons x xs)
(cons (car xs) (insert by x (cdr xs))))))
(if (null? xs) '()
(insert by (car xs) (sort by (cdr xs)))))

;; <variadic-tree> ::= <leaf> | (<variadic-tree> ...)
;; <leaf> is any non-list datum

(define (leaf? datum) (not (list? datum)))

(define (variadic-tree leaf nodes)
(lambda (tree)
(if (leaf? tree)
(leaf tree)
(apply nodes (map (variadic-tree leaf nodes) tree)))))

(define copy-tree (variadic-tree identity list))

(define exp-1
(copy-tree
'(+ (* (- x-1 x-2) (- x-1 x-2))
(* (- y-1 y-2) (- y-1 y-2))
(* (- z-1 z-2) (- z-1 z-2)))))

(define (splat tree)
(if (leaf? tree)
'()
(cons tree (concat-map splat tree))))

(define (subexpressions tree) (sort length (cdr (splat tree))))

(define (eliminate exp sub sym)
(cond ((null? exp) exp)
((leaf? exp) exp)
((cond ((equal? sub (car exp)) (set-car! exp sym))
(else (eliminate (car exp) sub sym)))
(eliminate (cdr exp) sub sym)
exp)))

(define gensym
(let ((n 0))
(lambda ()
(set! n (+ n 1))
(string->symbol (string-append "g" (number->string n))))))

(define (eliminate-subexpressions env exp subs)
(cond ((null? subs) `(let ,(reverse env) ,exp))
(else
(let* ((g (gensym))
(sub (car subs))
(exp-2 (eliminate exp sub g)))
(eliminate-subexpressions (cons (list g sub) env) exp-2 (subexpressions exp-2))))))

;; (eliminate-subexpressions '() exp-1 (subexpressions exp-1))
;; =>
;; (let ((g1 (- z-1 z-2))
;; (g2 (* g1 g1))
;; (g3 (- y-1 y-2))
;; (g4 (* g3 g3))
;; (g5 (- x-1 x-2))
;; (g6 (* g5 g5)))
;; (+ g6 g4 g2))

No comments: