[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Chicken-hackers] [PATCH] clustering
|
From: |
Felix |
|
Subject: |
[Chicken-hackers] [PATCH] clustering |
|
Date: |
Thu, 27 Oct 2011 05:15:41 -0400 (EDT) |
The attached patch adds an optimization (originally suggested by
chairman shinn), which turns groups of local procedures into "dispatch
loop". This can give good performance improvements in tight code that
performs no (or few) CPS calls. Currently it is not enabled by
default, but will probably later be enabled for optimization levels 2
and higher.
cheers,
felix
>From f99d033b411ed771793ff3043443f5c3d5cfb25b Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Sat, 15 Oct 2011 23:41:38 +0200
Subject: [PATCH] clustering optimization added
---
batch-driver.scm | 41 +++++++---
c-platform.scm | 2 +-
chicken.scm | 4 +
compiler-namespace.scm | 1 +
csc.scm | 4 +-
manual/Using the compiler | 4 +-
optimizer.scm | 205 +++++++++++++++++++++++++++++++++++++++++++++
scrutinizer.scm | 2 +-
support.scm | 15 +++-
tests/scrutiny.expected | 4 +-
types.db | 8 +-
11 files changed, 264 insertions(+), 26 deletions(-)
diff --git a/batch-driver.scm b/batch-driver.scm
index 1b30fdf..bc11bf4 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -88,6 +88,7 @@
(hgrowth (memq 'heap-growth options))
(hshrink (memq 'heap-shrinkage options))
(kwstyle (memq 'keyword-style options))
+ (loop/dispatch (memq 'clustering options))
(uses-units '())
(uunit (memq 'unit options))
(a-only (memq 'analyze-only options))
@@ -582,8 +583,11 @@
(print-node "cps" '|3| node1)
;; Optimization loop:
- (let loop ([i 1] [node2 node1] [progress #t])
-
+ (let loop ((i 1)
+ (node2 node1)
+ (progress #t)
+ (l/d #f)
+ (l/d-done #f))
(begin-time)
(let ([db (analyze 'opt node2 i progress)])
(when first-analysis
@@ -601,29 +605,42 @@
(end-time "analysis")
(print-db "analysis" '|4| db i)
- (when (memq 's debugging-chicken)
(print-program-statistics db))
+ (when (memq 's debugging-chicken)
+ (print-program-statistics db))
(cond (progress
(debugging 'p "optimization pass" i)
(begin-time)
(receive (node2 progress-flag)
- (perform-high-level-optimizations node2 db)
+ (if l/d
+ (determine-loop-and-dispatch node2 db)
+ (perform-high-level-optimizations node2 db))
(end-time "optimization")
(print-node "optimized-iteration" '|5| node2)
- (cond [progress-flag (loop (add1 i) node2 #t)]
- [(not inline-substitutions-enabled)
- (debugging 'p "rewritings enabled...")
+ (cond (progress-flag
+ (loop (add1 i) node2 #t #f l/d))
+ ((and (not l/d-done) loop/dispatch)
+ (debugging 'p "clustering enabled")
+ (loop (add1 i) node2 #t #t #t))
+ ((not inline-substitutions-enabled)
+ (debugging 'p "rewritings enabled")
(set! inline-substitutions-enabled #t)
- (loop (add1 i) node2 #t) ]
- [optimize-leaf-routines
+ (loop (add1 i) node2 #t #f l/d-done) )
+ (optimize-leaf-routines
(begin-time)
(let ([db (analyze 'leaf node2)])
(end-time "analysis")
(begin-time)
- (let ([progress
(transform-direct-lambdas! node2 db)])
+ (let ((progress
+ (transform-direct-lambdas! node2
db)))
(end-time "leaf routine optimization")
- (loop (add1 i) node2 progress) ) ) ]
- [else (loop (add1 i) node2 #f)] ) ) )
+ (loop (add1 i)
+ node2
+ progress
+ #f
+ l/d-done) ) ) )
+ (else
+ (loop (add1 i) node2 #f #f l/d-done)) ) ) )
(else
(print-node "optimized" '|7| node2)
diff --git a/c-platform.scm b/c-platform.scm
index 0e98754..807c006 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -91,7 +91,7 @@
no-procedure-checks-for-toplevel-bindings module
no-bound-checks no-procedure-checks-for-usual-bindings no-compiler-syntax
no-parentheses-synonyms no-symbol-escape r5rs-syntax
emit-all-import-libraries
- strict-types
+ strict-types clustering
lambda-lift ; OBSOLETE
setup-mode unboxing no-module-registration) )
diff --git a/chicken.scm b/chicken.scm
index 4aa066b..538fafa 100644
--- a/chicken.scm
+++ b/chicken.scm
@@ -88,6 +88,7 @@
(cons* 'optimize-leaf-routines
'inline
'unboxing
+ ;XXX 'clustering
options)) )
((3)
(set! options
@@ -95,6 +96,7 @@
'inline
'inline-global
'unboxing 'local
+ ;XXX 'clustering
'specialize
options) ) )
((4)
@@ -104,6 +106,7 @@
'inline-global
'unboxing
'specialize
+ ;XXX 'clustering
'local 'unsafe
options) ) )
(else
@@ -120,6 +123,7 @@
'no-lambda-info
'inline
'inline-global
+ ;XXX 'clustering
'unboxing
options) ) ) ) )
(loop (cdr rest)) ) )
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index b1929b1..bf41294 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -77,6 +77,7 @@
debugging
debugging-chicken
debugging-executable
+ determine-loop-and-dispatch
decompose-lambda-list
default-debugging-declarations
default-declarations
diff --git a/csc.scm b/csc.scm
index 11bbff0..8150c61 100644
--- a/csc.scm
+++ b/csc.scm
@@ -139,7 +139,7 @@
-no-argc-checks -no-bound-checks -no-procedure-checks -no-compiler-syntax
-emit-all-import-libraries -setup-mode -unboxing -no-elevation
-no-module-registration
-no-procedure-checks-for-usual-bindings -module
- -specialize -strict-types
+ -specialize -strict-types -clustering
-lambda-lift ; OBSOLETE
-no-procedure-checks-for-toplevel-bindings))
@@ -397,6 +397,8 @@ Usage: #{csc} FILENAME | OPTION ...
disable procedure call checks for toplevel
bindings
-strict-types assume variable do not change their type
+ -clustering combine groups of local procedures into
dispatch
+ loop
Configuration options:
diff --git a/manual/Using the compiler b/manual/Using the compiler
index a3470f2..e608e42 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -20,7 +20,7 @@ on the command line for a list of options.
be compiled. A filename argument of {{-}} specifies that
the source text should be read from standard input.
-==== Basic command-line options
+==== Command-line options
; -analyze-only : Stop compilation after first analysis pass.
@@ -30,6 +30,8 @@ the source text should be read from standard input.
; -check-syntax : Aborts compilation process after macro-expansion and syntax
checks.
+; -clustering : Combine groups of local procedures into dispatch-loops, if
possible.
+
; -consult-inline-file FILENAME : load file with definitions for cross-module
inlining generated by a previous compiloer invocation via
{{-emit-inline-file}}. Implies {{-inline}}.
; -debug MODES : Enables one or more compiler debugging modes. {{MODES}} is a
string of characters that select debugging information about the compiler that
will be printed to standard output. Use {{-debug h}} to see a list of available
debugging options.
diff --git a/optimizer.scm b/optimizer.scm
index e0f4214..ab4e67d 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -1522,3 +1522,208 @@
(debugging 'p "direct leaf routine optimization pass...")
(walk #f node #f)
dirty) )
+
+
+;;; turn groups of local procedures into dispatch loop ("clustering")
+;
+; This turns (in bodies)
+;
+; :
+; (define (a x) (b x))
+; (define (b y) (a y))
+; (a z)))
+;
+; into something similar to
+;
+; (letrec ((<dispatch>
+; (lambda (<a1> <i>)
+; (case <i>
+; ((1) (let ((x <a1>)) (<dispatch> x 2)))
+; ((2) (let ((y <a1>)) (<dispatch> y 1)))
+; (else (<dispatch> z 1))))))
+; (<dispatch> #f 0))
+
+(define (determine-loop-and-dispatch node db)
+ (let ((groups '())
+ (outer #f)
+ (group '()))
+
+ (define (close) ; "close" group of local definitions
+ (when (pair? group)
+ (when (> (length group) 1)
+ (set! groups (alist-cons outer group groups)))
+ (set! group '())
+ (set! outer #f)))
+
+ (define (user-lambda? n)
+ (and (eq? '##core#lambda (node-class n))
+ (list? (third (node-parameters n))))) ; no rest argument allowed
+
+ (define (walk n e)
+ (let ((subs (node-subexpressions n))
+ (params (node-parameters n))
+ (class (node-class n)) )
+ (case class
+ ((let)
+ (let ((var (first params))
+ (val (first subs))
+ (body (second subs)))
+ (cond ((and (not outer)
+ (eq? '##core#undefined (node-class val)))
+ ;; find outermost "(let ((VAR (##core#undefined))) ...)"
+ (set! outer n)
+ (walk body (cons var e)))
+ ((and outer
+ (eq? 'set! (node-class val))
+ (let ((sval (first (node-subexpressions val)))
+ (svar (first (node-parameters val))))
+ ;;XXX should we also accept "##core#direct_lambda" ?
+ (and (eq? '##core#lambda (node-class sval))
+ (= (length (or (get db svar 'references) '()))
+ (length (or (get db svar 'call-sites) '())))
+ (memq svar e)
+ (user-lambda? sval))))
+ ;; "(set! VAR (lambda ...))" - add to group
+ (set! group (cons val group))
+ (walk body (cons var e)))
+ (else
+ ;; other "let" binding, close group (if any)
+ (close)
+ (walk val e)
+ (walk body (cons var e))))))
+ ((##core#lambda ##core#direct_lambda)
+ (decompose-lambda-list
+ (third params)
+ (lambda (vars argc rest)
+ ;; walk recursively, with cleared cluster state
+ (fluid-let ((group '())
+ (outer #f))
+ (walk (first subs) vars)))))
+ (else
+ ;; other form, close group (if any)
+ (close)
+ (for-each (cut walk <> e) subs)))))
+
+ (debugging 'p "collecting clusters ...")
+
+ ;; walk once and gather groups
+ (walk node '())
+
+ ;; process found clusters
+ (for-each
+ (lambda (g)
+ (let* ((outer (car g))
+ (group (cdr g))
+ (dname (gensym 'dispatch))
+ (i (gensym 'i))
+ (n 1)
+ (bodies
+ (map (lambda (assign)
+ ;; collect information and replace assignment
+ ;; with "(##core#undefined)"
+ (let* ((name (first (node-parameters assign)))
+ (proc (first (node-subexpressions assign)))
+ (pparams (node-parameters proc))
+ (llist (third pparams))
+ (aliases (map gensym llist)))
+ (decompose-lambda-list
+ llist
+ (lambda (vars argc rest)
+ (let ((body (first (node-subexpressions proc)))
+ (m n))
+ (set! n (add1 n))
+ (copy-node!
+ (make-node '##core#undefined '() '())
+ assign)
+ (list name m llist body))))))
+ group))
+ (k (gensym 'k))
+ (maxargs (apply max (map (o length third) bodies)))
+ (dllist (append
+ (list-tabulate maxargs (lambda _ (gensym 'a)))
+ (list i))))
+
+ (debugging 'x "clustering" (map first bodies)) ;XXX
+
+ ;; first descend into "(let ((_ (##core#undefined))) ...)" forms
+ ;; to make them visible everywhere
+
+ (let descend ((outer outer))
+ ;;(print "outer: " (node-parameters outer))
+ (let ((body (second (node-subexpressions outer))))
+ (if (and (eq? 'let (node-class body))
+ (let ((val (first (node-subexpressions body))))
+ (eq? '##core#undefined (node-class val))))
+ (descend body)
+ ;; wrap cluster into dispatch procedure
+ (copy-node!
+ (make-node
+ 'let
+ (list dname)
+ (list
+ (make-node '##core#undefined '() '())
+ (make-node
+ 'let (list (gensym))
+ (list
+ (make-node
+ 'set! (list dname)
+ (list
+ (make-node
+ '##core#lambda
+ (list (gensym 'f_) #t dllist 0)
+ (list
+ ;; dispatch to cluster member or main body
+ (make-node
+ '##core#switch
+ (list (sub1 n))
+ (append
+ (list (varnode i))
+ (append-map
+ (lambda (b)
+ (list (qnode (second b))
+ (let loop ((args dllist)
+ (vars (third b)))
+ (if (null? vars)
+ (fourth b)
+ (make-node
+ 'let (list (car vars))
+ (list (varnode (car args))
+ (loop (cdr args) (cdr
vars))))))))
+ bodies)
+ (cdr (node-subexpressions outer))))))))
+ ;; call to enter dispatch loop - the current continuation
is
+ ;; not used, so the first parameter is passed as "#f" (it
is
+ ;; a tail call)
+ (make-node
+ '##core#call '(#t)
+ (cons* (varnode dname)
+ (append
+ (list-tabulate maxargs (lambda _ (qnode #f)))
+ (list (qnode 0)))))))))
+ outer))))
+
+ ;; modify call-sites to invoke dispatch loop instead
+ (for-each
+ (lambda (b)
+ (let ((sites (get db (car b) 'call-sites)))
+ (for-each
+ (lambda (site)
+ (let* ((callnode (cdr site))
+ (args (cdr (node-subexpressions callnode))))
+ (copy-node!
+ (make-node
+ '##core#call (node-parameters callnode)
+ (cons* (varnode dname)
+ (append
+ args
+ (list-tabulate
+ (- maxargs (length args))
+ (lambda _ (qnode #f)))
+ (list (qnode (second b))))))
+ callnode)))
+ sites)))
+ bodies)))
+
+ groups)
+ (values node (pair? groups))))
+
diff --git a/support.scm b/support.scm
index 921b97a..30818bd 100644
--- a/support.scm
+++ b/support.scm
@@ -396,6 +396,7 @@
(inline-target . ilt) (inline-transient . itr)
(undefined . und) (replacing . rpg) (unused . uud)
(extended-binding . xtb)
(inline-export . ilx) (hidden-refs . hrf)
+ (value-ref . vvf)
(customizable . cst) (has-unused-parameters . hup) (boxed-rest
. bxr) ) )
(omit #f))
(lambda (db)
@@ -580,7 +581,11 @@
((##core#closure)
`(##core#closure ,params ,@(map walk subs)) )
((##core#variable) (car params))
- ((quote) `(quote ,(car params)))
+ ((quote)
+ (let ((c (car params)))
+ (if (or (boolean? c) (string? c) (number? c) (char? c))
+ c
+ `(quote ,(car params)))))
((let)
`(let ,(map list params (map walk (butlast subs)))
,(walk (last subs)) ) )
@@ -1635,12 +1640,14 @@ Usage: chicken FILENAME OPTION ...
-no-bound-checks disable bound variable checks
-no-procedure-checks disable procedure call checks
-no-procedure-checks-for-usual-bindings
- disable procedure call checks only for usual
- bindings
+ disable procedure call checks only for usual
+ bindings
-no-procedure-checks-for-toplevel-bindings
disable procedure call checks for toplevel
- bindings
+ bindings
-strict-types assume variable do not change their type
+ -clustering combine groups of local procedures into
dispatch
+ loop
Configuration options:
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index c735c80..2a24292 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -8,12 +8,12 @@ Note: in local procedure `c',
expected value of type boolean in conditional but were given a value of type
`number' which is always true:
-(if x3 '1 '2)
+(if x3 1 2)
Warning: in toplevel procedure `foo':
branches in conditional expression differ in the number of results:
-(if x5 (values '1 '2) (values '1 '2 (+ (+ ...))))
+(if x5 (values 1 2) (values 1 2 (+ (+ ...))))
Warning: at toplevel:
scrutiny-tests.scm:18: in procedure call to `bar6', expected argument #2 of
type `number', but was given an argument of type `symbol'
diff --git a/types.db b/types.db
index 1676962..6701307 100644
--- a/types.db
+++ b/types.db
@@ -35,10 +35,10 @@
; - in templates "#(SYMBOL)" binds X to a temporary gensym'd variable, further
references
; to "#(SYMBOL)" allow backreferences to this generated identifier
; - "#(procedure PROPERTY ...)" may be used in place of "procedure",
properties are:
-; #:clean
-; #:enforce
-; #:predicate TYPE
-; #:pure
+; #:clean - procedure does not modify state that might be used locally
+; #:enforce - when procedure returns, arguments are of correct type
+; #:predicate TYPE - procedure is a predicate on TYPE
+; #:pure - procedure has no side effects
; - "#:clean" means: will not invoke procedures that modify local variables and
; will not modify list or vector data held locally (note that I/O may invoke
; port handlers)
--
1.7.6.msysgit.0
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Chicken-hackers] [PATCH] clustering,
Felix <=