~ chicken-core (chicken-5) bae7d92d9d1d17330b43fba4e278159c7d0d7fc1
commit bae7d92d9d1d17330b43fba4e278159c7d0d7fc1
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Oct 15 23:41:38 2011 +0200
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Fri Nov 11 15:02:30 2011 +0100
clustering optimization added
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/batch-driver.scm b/batch-driver.scm
index 1bd4f678..cd1cd609 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -85,6 +85,7 @@
(and-let* ((pn (memq 'profile-name options))) (cadr pn)))
(hsize (memq 'heap-size options))
(kwstyle (memq 'keyword-style options))
+ (loop/dispatch (memq 'clustering options))
(uses-units '())
(uunit (memq 'unit options))
(a-only (memq 'analyze-only options))
@@ -573,8 +574,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
@@ -592,29 +596,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 5d69bcdf..fbe77ac1 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 4aa066bb..538fafac 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 819aae11..9cf865f8 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -78,6 +78,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 8afbdf63..b5da715a 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))
@@ -399,6 +399,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 9d9253e8..c99f9984 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 40974dda..aa5f7fd8 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -1526,3 +1526,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 8bf2b6d0..97ba03ab 100644
--- a/support.scm
+++ b/support.scm
@@ -434,6 +434,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)
@@ -618,7 +619,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)) ) )
@@ -1673,12 +1678,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 c735c802..2a242925 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 1676962e..67013070 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)
Trap