Permalink
Browse files

Implement splitting of flat trees by common subsets.

Add code to determine that e.g. (+ a b c d) and
(+ a c d) have a common subpart, and split it off
so that it can be further exploited by the common
subexpression elimination pass.

Works by doing a O(N^2) intersection of all similar
terms, and then extracting subsets in a certain order
of precedence.
  • Loading branch information...
1 parent b88da56 commit 9eea67d82023a60ae811044a0d3958c2344deb23 @angavrilov committed Sep 19, 2009
Showing with 186 additions and 1 deletion.
  1. +180 −0 expr/opt-cse.lisp
  2. +1 −0 expr/opt-flatten.lisp
  3. +1 −1 expr/opt-treeify.lisp
  4. +3 −0 formula.el
  5. +1 −0 load.lisp
View
@@ -0,0 +1,180 @@
+;;; -*- mode:lisp; indent-tabs-mode: nil; -*-
+
+(in-package fast-compute)
+
+(use-std-readtable)
+
+(defun has-minus-p (expr)
+ (match expr
+ (`(- ,_) t)))
+
+(defun has-div-p (expr)
+ (match expr
+ (`(/ ,(type number _)) nil)
+ (`(/ ,_) t)
+ (`(- (/ ,_)) t)))
+
+;; Common subset extractor code
+
+(defcontext common-subset-extract (op #'inv-func #'inv-p)
+ ;; Mapping of original canonic-expr's to current content bags
+ (deflex work-bags (make-hash-table))
+
+ ;; Set of work-bags keys still in processing
+ (deflex active-set (empty-set))
+
+ ;; Queue of subsets to extract, in form (cons penalty bag)
+ (deflex pull-queue (empty-set))
+
+ ;; Specifies where the subset comes from (used for efficiency)
+ (deflex pull-index (with-default (empty-map) (empty-set))) ; subset bag -> old-expr*
+
+ (defun get-state () ; for debug
+ (values (hash-table-alist work-bags)
+ active-set pull-queue pull-index))
+
+ ;; Misc. conversions
+ (defun invert (expr-bag)
+ (image #f(canonic inv-func _) expr-bag))
+
+ (defun bag-to-expr (expr-bag)
+ (let ((ilist (convert 'list expr-bag)))
+ (if (cdr ilist)
+ (make-canonic (list* op ilist))
+ (car ilist))))
+
+ (defun expr-to-bag (expr)
+ (let ((ce (canonic-expr-unwrap expr)))
+ (assert (and (consp ce) (eql (car ce) op)))
+ (convert 'bag (mapcar #'make-canonic (cdr ce)))))
+
+ ;; Queue
+ (defun bag-queue-descriptor (expr-bag)
+ (cons (cons (- (size expr-bag)) ; Prioritize largest
+ ;; Prioritize least inverted:
+ (count-if #f(canonic-in inv-p _) expr-bag))
+ expr-bag))
+
+ (defun dequeue-bag (expr-bag)
+ (removef pull-queue (bag-queue-descriptor expr-bag))
+ (removef pull-index expr-bag))
+
+ (defun queue-bag (expr-bag &rest exprs)
+ (adjoinf pull-queue (bag-queue-descriptor expr-bag))
+ (unionf (@ pull-index expr-bag) (convert 'set exprs)))
+
+ (defun get-next-cut ()
+ (let* ((head (least pull-queue))
+ (bag (cdr head))
+ (exprs (@ pull-index bag)))
+ (removef pull-queue head)
+ (removef pull-index bag)
+ (values bag exprs)))
+
+ ;; Subset finder
+ (defun requeue-expr (expr)
+ (let* ((expr-bag (gethash expr work-bags))
+ (inv-bag (invert expr-bag)))
+ (when (>= (size expr-bag) 2)
+ ;; Iterate active expressions
+ (do-set (expr2 active-set)
+ (let* ((bag2 (gethash expr2 work-bags))
+ (intf (intersection expr-bag bag2))
+ (inti (intersection inv-bag bag2)))
+ ;; Queue forward match
+ (when (> (size intf) 1)
+ (queue-bag intf expr expr2))
+ ;; Queue inverted match
+ (when (> (size inti) 1)
+ (queue-bag inti expr expr2)
+ (queue-bag (invert inti) expr expr2))))
+ ;; Activate the expression
+ (adjoinf active-set expr))))
+
+ (defun enqueue-expr (expr)
+ (setf (gethash expr work-bags) (expr-to-bag expr))
+ (requeue-expr expr))
+
+ ;; Split cycle
+ (defun process-one-split ()
+ (multiple-value-bind (cut-bag exprs) (get-next-cut)
+ (let* ((inv-bag (invert cut-bag))
+ (cut-expr (bag-to-expr cut-bag))
+ (inv-expr (canonic inv-func cut-expr))
+ (changed-exprs (empty-set))
+ (scan-set (less (intersection exprs active-set)
+ cut-expr)))
+ ;; Kill the opposite
+ (dequeue-bag inv-bag)
+ ;; Process pending expressions
+ (do-set (expr scan-set)
+ (let* ((cur-bag (gethash expr work-bags))
+ (changed nil))
+ ;; Forward split
+ (do ((cnt 0 (1+ cnt)))
+ ((not (subbag? cut-bag cur-bag))
+ (setf cur-bag (with cur-bag cut-expr cnt)))
+ (setf changed t)
+ (setf cur-bag (bag-difference cur-bag cut-bag)))
+ ;; Inverted split
+ (do ((cnt 0 (1+ cnt)))
+ ((not (subbag? inv-bag cur-bag))
+ (setf cur-bag (with cur-bag inv-expr cnt)))
+ (setf changed t)
+ (setf cur-bag (bag-difference cur-bag inv-bag)))
+ ;; Save changes
+ (when changed
+ (adjoinf changed-exprs expr)
+ (setf (gethash expr work-bags) cur-bag))))
+ ;; Register the new node
+ (unless (or (empty? changed-exprs)
+ (gethash cut-expr work-bags))
+ (setf (gethash cut-expr work-bags) cut-bag)
+ (adjoinf changed-exprs cut-expr))
+ ;; Requeue changed expressions
+ (setf active-set (set-difference active-set changed-exprs))
+ (do-set (expr changed-exprs)
+ (requeue-expr expr)))))
+
+ (defun process-splits ()
+ (until (empty? pull-queue)
+ (process-one-split)))
+
+ ;; Output mapping
+ (defun make-replace-hash (&optional (hash (make-hash-table)))
+ (maphash (lambda (expr bag)
+ (let ((new-expr (bag-to-expr bag)))
+ (unless (eql expr new-expr)
+ (setf (gethash expr hash) new-expr))))
+ work-bags)
+ hash)
+
+ (defun process-all (exprs repl-table)
+ (mapc #'enqueue-expr exprs)
+ (process-splits)
+ (make-replace-hash repl-table)))
+
+
+;; Wrapper
+
+(defun split-by-cse (expr)
+ (let ((expr-table (make-hash-table))
+ (add-list nil)
+ (mul-list nil)
+ (fix-table (make-hash-table)))
+ ;; Collect additions and multiplications
+ (count-subexprs-rec (canonic-expr-unwrap expr) expr-table)
+ (maphash (lambda (sub cnt)
+ (match sub
+ (`(+ ,@_)
+ (push (make-canonic sub) add-list))
+ (`(* ,@_)
+ (push (make-canonic sub) mul-list))))
+ expr-table)
+ ;; Determine the splits
+ (with-context (common-subset-extract '+ #'toggle-minus #'has-minus-p)
+ (process-all add-list fix-table))
+ (with-context (common-subset-extract '* #'toggle-div #'has-div-p)
+ (process-all mul-list fix-table))
+ ;; Substitute them
+ (canonic-substitute fix-table expr :replace-once nil)))
View
@@ -77,6 +77,7 @@
(match expr
(1 1)
(`(/ ,x) x)
+ (`(- (/ ,x)) `(- ,x))
(x `(/ ,x))))
(defun collect* (args)
View
@@ -52,6 +52,6 @@
(pipeline (make-canonic expr)
flatten-exprs pull-minus pull-factors
optimize-ifsign expand-ifsign
- split-by-level
+ split-by-level split-by-cse
canonic-expr-unwrap
treeify))
View
@@ -141,6 +141,9 @@ When Formula mode is enabled, code within {} is indented specially."
(put 'letmatch 'common-lisp-indent-function
'(6 nil &body))
+(put 'while 'common-lisp-indent-function 1)
+(put 'until 'common-lisp-indent-function 1)
+
;; formula parser
(put 'binary-ops 'common-lisp-indent-function
'(4 4 &rest (&whole 2 4 2)))
View
@@ -40,6 +40,7 @@
"expr/opt-flatten.lisp"
"expr/opt-pullexpr.lisp"
"expr/opt-ifsign.lisp"
+ "expr/opt-cse.lisp"
"expr/opt-treeify.lisp"
"expr/let-utils.lisp"
"expr/cse.lisp"

0 comments on commit 9eea67d

Please sign in to comment.