~ chicken-core (chicken-5) 2a94e86f0aac76e42b31135ba127306464219794
commit 2a94e86f0aac76e42b31135ba127306464219794
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Dec 8 22:14:22 2010 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Dec 8 22:14:22 2010 +0100
added lambda-lifter back again as it proved to be effective in one use case
diff --git a/batch-driver.scm b/batch-driver.scm
index 0d6372c8..dff1c857 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -182,6 +182,7 @@
(not a-only))
(set! all-import-libraries #t))
(set! enable-module-registration (not (memq 'no-module-registration options)))
+ (when (memq 'lambda-lift options) (set! do-lambda-lifting #t))
(when (memq 'scrutinize options) (set! do-scrutinize #t))
(when (memq 't debugging-chicken) (##sys#start-timer))
(when (memq 'b debugging-chicken) (set! time-breakdown #t))
@@ -508,6 +509,19 @@
(end-time "scrutiny")
(set! first-analysis #t) )
+ (when do-lambda-lifting
+ (begin-time)
+ (unless do-scrutinize ; no need to do analysis if already done above
+ (set! first-analysis #f)
+ (set! db (analyze 'lift node0))
+ (print-db "analysis" '|0| db 0)
+ (end-time "pre-analysis (lambda-lift)"))
+ (begin-time)
+ (perform-lambda-lifting! node0 db)
+ (end-time "lambda lifting")
+ (print-node "lambda lifted" '|L| node0)
+ (set! first-analysis #t) )
+
(let ((req (concatenate (vector->list file-requirements))))
(when (debugging 'M "; requirements:")
(pp req))
diff --git a/c-platform.scm b/c-platform.scm
index ae4a52a4..e95b68b4 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -84,8 +84,7 @@
check-syntax to-stdout no-usual-integrations case-insensitive no-lambda-info
profile inline keep-shadowed-macros ignore-repository
fixnum-arithmetic disable-interrupts optimize-leaf-routines
- lambda-lift ; OBSOLETE
- compile-syntax tag-pointers accumulate-profile
+ lambda-lift compile-syntax tag-pointers accumulate-profile
disable-stack-overflow-checks raw
emit-external-prototypes-first release local inline-global
analyze-only dynamic scrutinize no-argc-checks no-procedure-checks
diff --git a/chicken.scm b/chicken.scm
index cd840e07..441bd072 100644
--- a/chicken.scm
+++ b/chicken.scm
@@ -100,7 +100,7 @@
(when (>= level 5)
(set! options
(cons* 'disable-interrupts 'no-trace 'unsafe 'block
- 'optimize-leaf-routines 'no-lambda-info
+ 'optimize-leaf-routines 'lambda-lift 'no-lambda-info
'inline 'inline-global 'unboxing
options) ) ) ) )
(loop (cdr rest)) ) )
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 28ce46aa..91c9b47e 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -98,6 +98,7 @@
display-analysis-database
display-line-number-database
display-real-name-table
+ do-lambda-lifting
do-scrutinize
dump-defined-globals
dump-global-refs
@@ -219,6 +220,7 @@
perform-cps-conversion
perform-high-level-optimizations
perform-inlining!
+ perform-lambda-lifting!
perform-pre-optimization!
perform-unboxing!
posq
diff --git a/compiler.scm b/compiler.scm
index 2cc164a5..0c526fa9 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -57,6 +57,7 @@
; (hide {<name>})
; (inline-limit <limit>)
; (keep-shadowed-macros)
+; (lambda-lift)
; (no-argc-checks)
; (no-bound-checks)
; (no-procedure-checks)
@@ -320,6 +321,7 @@
(define disable-stack-overflow-checking #f)
(define require-imports-flag #f)
(define external-protos-first #f)
+(define do-lambda-lifting #f)
(define inline-max-size default-inline-max-size)
(define emit-closure-info #t)
(define undefine-shadowed-macros #t)
@@ -1400,7 +1402,7 @@
(for-each export-variable syms)))
((emit-external-prototypes-first)
(set! external-protos-first #t) )
- ((lambda-lift) #f) ; OBSOLETE
+ ((lambda-lift) (set! do-lambda-lifting #t))
((inline)
(if (null? (cdr spec))
(set! inline-locally #t)
diff --git a/csc.scm b/csc.scm
index 4067ea07..65d35695 100644
--- a/csc.scm
+++ b/csc.scm
@@ -133,8 +133,7 @@
'(-explicit-use -no-trace -no-warnings -no-usual-integrations -optimize-leaf-routines -unsafe
-block -disable-interrupts -fixnum-arithmetic -to-stdout -profile -raw -accumulate-profile
-check-syntax -case-insensitive -shared -compile-syntax -no-lambda-info
- -lambda-lift ; OBSOLETE
- -dynamic -disable-stack-overflow-checks -local
+ -lambda-lift -dynamic -disable-stack-overflow-checks -local
-emit-external-prototypes-first -inline -release -scrutinize
-analyze-only -keep-shadowed-macros -inline-global -ignore-repository
-no-symbol-escape -no-parentheses-synonyms -r5rs-syntax
@@ -372,6 +371,7 @@ Usage: #{csc} FILENAME | OPTION ...
-b -block enable block-compilation
-disable-interrupts disable interrupts in compiled code
-f -fixnum-arithmetic assume all numbers are fixnums
+ -lambda-lift perform lambda-lifting
-disable-stack-overflow-checks disables detection of stack-overflows
-inline enable inlining
-inline-limit LIMIT set inlining threshold
diff --git a/manual/Declarations b/manual/Declarations
index 56b1a458..99a1e225 100644
--- a/manual/Declarations
+++ b/manual/Declarations
@@ -161,6 +161,13 @@ Normally, when a toplevel variable is assigned or defined that has the same name
will be removed (in addition to showing a warning). This declaration will disable the removal of the macro.
+=== lambda-lift
+
+ [declaration specifier] (lambda-lift)
+
+Enables lambda-lifting (equivalent to the {{-lambda-lift}} option).
+
+
=== local
[declaration specifier] (local)
diff --git a/manual/Using the compiler b/manual/Using the compiler
index ebbff6f5..b1c22629 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -41,6 +41,7 @@ the source text should be read from standard input.
s show program-size information and other statistics
a show node-matching during simplification
p show execution of compiler sub-passes
+ l show lambda-lifting information
m show GC statistics during compilation
n print the line-number database
c print every expression before macro-expansion
@@ -49,8 +50,10 @@ the source text should be read from standard input.
x display information about experimental features
D when printing nodes, use node-tree output
N show the real-name mapping table
+ 0 show database before lambda-lifting pass
S show applications of compiler syntax
T show expressions after converting to node tree
+ L show expressions after lambda-lifting
U show expressions after unboxing
M show syntax-/runtime-requirements
1 show source expressions
@@ -117,6 +120,8 @@ the source text should be read from standard input.
; -keep-shadowed-macros : Do not remove macro definitions with the same name as assigned toplevel variables (the default is to remove the macro definition).
+; -lambda-lift : Enable the optimization known as lambda-lifting.
+
; -local : Assume toplevel variables defined in the current compilation unit are not externally modified. This gives the compiler more opportunities for inlining. Note that this may result in counter-intuitive and non-standard behaviour: an asssignment to an exported toplevel variable executed in a different compilation unit or in evaluated code will possibly not be seen by code executing in the current compilation unit.
; -module : wraps the compiled code in an implicit module named {{main}}, importing the {{scheme}} and {{chicken}} modules.
@@ -157,7 +162,7 @@ the source text should be read from standard input.
-optimize-level 2 is equivalent to -optimize-leaf-routines -inline -unboxing
-optimize-level 3 is equivalent to -optimize-leaf-routines -local -inline -inline-global -unboxing
-optimize-level 4 is equivalent to -optimize-leaf-routines -local -inline -inline-global -unboxing -unsafe
- -optimize-level 5 is equivalent to -optimize-leaf-routines -block -inline -inline-global -unsafe -unboxing -disable-interrupts -no-trace -no-lambda-info
+ -optimize-level 5 is equivalent to -optimize-leaf-routines -block -inline -inline-global -unsafe -unboxing -lambda-lift -disable-interrupts -no-trace -no-lambda-info
; -output-file FILENAME : Specifies the pathname of the generated C file. Default is {{FILENAME.c}}.
diff --git a/optimizer.scm b/optimizer.scm
index 839b6caf..0cdf29d9 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -33,6 +33,8 @@
(include "compiler-namespace")
(include "tweaks")
+(define-constant maximal-number-of-free-variables-for-liftable 16)
+
;;; Scan toplevel expressions for assignments:
@@ -1473,3 +1475,367 @@
(debugging 'p "direct leaf routine optimization pass...")
(walk #f node #f)
dirty) )
+
+
+;;; Lambda lift:
+;
+; - Find lambda-liftable local procedures and lift them to toplevel.
+; - Pass free variables as extra parameters, including the free variables of
+; other lifted procedures. This implies that lifted procedures that call each
+; other have to be in the same scope.
+; - Declare the lifted procedures (effectively) as bound-to-procedure and block-global.
+
+(define (perform-lambda-lifting! node db)
+ (let ([lambda-values '()]
+ [eliminated '()] )
+
+ (define (find-lifting-candidates)
+ ;; Collect potentially liftable procedures and return as a list of (<name> . <value>) pairs:
+ ;; - Also build a-list that maps lambda-nodes to names.
+ (let ((cs '()))
+ (##sys#hash-table-for-each
+ (lambda (sym plist)
+ (and-let* ((val (assq 'value plist))
+ (refs (assq 'references plist))
+ (css (assq 'call-sites plist)) )
+ (let ((nrefs (length (cdr refs))))
+ (when (and (not (assq 'unknown plist))
+ (eq? 'lambda (node-class (cdr val)))
+ (not (assq 'global plist))
+ #;(> nrefs 1)
+ (= nrefs (length (cdr css))) )
+ (set! lambda-values (alist-cons (cdr val) sym lambda-values))
+ (set! cs (alist-cons sym (cdr val) cs)) ) ) ) )
+ db)
+ cs) )
+
+ (define (build-call-graph cs)
+ ;; Build call-graph of the form ((<name> (<free1> ...) <called1> ...) ...):
+ (let ([g '()]
+ [free '()]
+ [called '()] )
+
+ (define (walk n env)
+ (let ([class (node-class n)]
+ [params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case class
+ [(##core#variable set!)
+ (let ([var (first params)])
+ (unless (or (memq var env) (get db var 'global))
+ (set! free (cons var free)) )
+ (when (assq var cs) (set! called (cons var called)))
+ (for-each (lambda (n) (walk n env)) subs) ) ]
+ [(let)
+ (let loop ([vars params] [vals subs])
+ (if (null? vars)
+ (walk (car vals) (append params env))
+ (let ([var (car vars)])
+ (walk (car vals) env)
+ (loop (cdr vars) (cdr vals)) ) ) ) ]
+ [(lambda)
+ (decompose-lambda-list
+ (first params)
+ (lambda (vars argc rest) (walk (first subs) (append vars env))) ) ]
+ [else (for-each (lambda (n) (walk n env)) subs)] ) ) )
+
+ (for-each
+ (lambda (cs)
+ (let* ([here (car cs)]
+ [lval (cdr cs)]
+ [llist (car (node-parameters lval))] )
+ (set! free '())
+ (set! called '())
+ (decompose-lambda-list
+ llist
+ (lambda (vars arg rest)
+ (walk (car (node-subexpressions lval)) vars) ) )
+ (set! g (alist-cons here (cons free called) g)) ) )
+ cs)
+ g) )
+
+ (define (eliminate cs graph)
+ ;; Eliminate all liftables that have free variables that are assigned to (and are not liftable),
+ ;; or that have more than N free variables (including free variables of called liftables):
+ (remove
+ (lambda (gn)
+ (or (> (count-free-variables (car gn) graph) maximal-number-of-free-variables-for-liftable)
+ (any (lambda (v)
+ (and (get db v 'assigned)
+ (not (assq v cs)) ) )
+ (second gn) ) ) )
+ graph) )
+
+ (define (count-free-variables name graph)
+ (let ([gnames (unzip1 graph)])
+ (let count ([n name] [walked '()])
+ (let* ([a (assq n graph)]
+ [cs (lset-difference eq? (cddr a) walked gnames)]
+ [f (length (delete-duplicates (second a) eq?))]
+ [w2 (cons n (append cs walked))] )
+ (fold + f (map (lambda (c) (count c w2)) cs)) ) ) ) )
+
+ (define (collect-accessibles graph)
+ ;; Collect accessible variables for each liftable into list of the form (<name> <accessible1> ...):
+ (let ([al '()])
+ (let walk ([n node] [vars '()])
+ (let ([class (node-class n)]
+ [params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case class
+ [(##core#variable quote ##core#undefined ##core#primitive ##core#proc) #f]
+ [(let)
+ (let loop ([vars2 params] [vals subs])
+ (if (null? vars2)
+ (walk (car vals) (append params vars))
+ (begin
+ (walk (car vals) vars)
+ (loop (cdr vars2) (cdr vals)) ) ) ) ]
+ [(lambda)
+ (let ([lval (assq n lambda-values)])
+ (when lval
+ (let ([name (cdr lval)])
+ (when (assq name graph)
+ (set! al (alist-cons (cdr lval) vars al))) ) ) )
+ (decompose-lambda-list
+ (first params)
+ (lambda (vars2 argc rest)
+ (walk (car subs) (append vars2 vars)) ) ) ]
+ [else
+ (for-each (lambda (n) (walk n vars)) subs) ] ) ) )
+ al) )
+
+ (define (eliminate2 graph al)
+ ;; Eliminate liftables that have call-sites without access to all free variables;
+ (remove
+ (lambda (gn)
+ (let* ([name (first gn)]
+ [free (second gn)] )
+ (any (lambda (gn2)
+ (and (memq name (cddr gn2)) ; callee?
+ (lset<= eq? (cdr (assq (car gn2) al)) free) ) )
+ graph) ) )
+ graph) )
+
+ (define (eliminate3 graph)
+ ;; Eliminate liftables that call other eliminated liftables:
+ ;; - repeat until nothing changes.
+ (let loop ([graph graph] [n (length graph)])
+ (let* ([g2 (filter (lambda (gn) (every (lambda (n) (assq n graph)) (cddr gn))) graph)]
+ [n2 (length g2)] )
+ (if (= n n2)
+ g2
+ (loop g2 n2) ) ) ) )
+
+ (define (eliminate4 graph)
+ ;; Eliminate liftables that have unknown call-sites which do not have access to
+ ;; any of the free variables of all callees:
+ (let walk ([n node] [vars '()])
+ (let ([class (node-class n)]
+ [params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case class
+ [(##core#variable quote ##core#undefined ##core#primitive ##core#proc) #f]
+ [(let)
+ (let loop ([vars2 params] [vals subs])
+ (if (null? vars2)
+ (walk (car vals) (append params vars))
+ (begin
+ (walk (car vals) vars)
+ (loop (cdr vars2) (cdr vals)) ) ) ) ]
+ [(lambda)
+ (decompose-lambda-list
+ (first params)
+ (lambda (vars2 argc rest)
+ (walk (car subs) (append vars2 vars)) ) ) ]
+ [(##core#call)
+ (let ([fn (first subs)])
+ (call-with-current-continuation
+ (lambda (return)
+ (when (eq? '##core#variable (node-class fn))
+ (let ([done '()])
+ (let loop ([name (first (node-parameters fn))])
+ (unless (memq name done)
+ (set! done (cons name done))
+ (let ([gn (assq name graph)])
+ (when gn
+ (unless (lset<= eq? (second gn) vars)
+ #;(print "*** " (first (node-parameters fn)) " | " name ": " vars " / " (second gn))
+ (set! graph (delete! gn graph eq?))
+ (return #f) )
+ (for-each loop (cddr gn)) ) ) ) ) ) ) ) )
+ (for-each (lambda (n) (walk n vars)) subs) ) ]
+ [else (for-each (lambda (n) (walk n vars)) subs)] ) ) )
+ graph)
+
+ (define (compute-extra-variables graph)
+ ;; Gather variables that have to be passed additionally:
+ ;; - do not pass variables that are defined inside the body of a liftable.
+ (define (defined n)
+ (let ([defd '()])
+ (let walk ([n n])
+ (let ([class (node-class n)]
+ [params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case class
+ [(let)
+ (set! defd (append params defd))
+ (for-each walk subs) ]
+ [(lambda)
+ (decompose-lambda-list
+ (first params)
+ (lambda (vars argc rest)
+ (set! defd (append vars defd))
+ (walk (first subs)) ) ) ]
+ [else (for-each walk subs)] ) ) )
+ defd) )
+ (let ([extras (map (lambda (gn) (cons (first gn) (second gn))) graph)]
+ [walked '()] )
+ (define (walk gn)
+ (let ([name (car gn)])
+ ;; Hm. To handle liftables that are called recursively (but indirect) I use this kludge. Is it safe?
+ (unless (> (count (cut eq? name <>) walked) 1)
+ (set! walked (cons name walked))
+ (let ([callees (cddr gn)])
+ (for-each (lambda (c) (walk (assq c graph))) callees)
+ (let ([f (assq name extras)])
+ (set-cdr! f (append (cdr f) (concatenate (map (lambda (n2) (cdr (assq n2 extras))) callees)))) ) ) ) ) )
+ (for-each walk graph)
+ (map (lambda (xt)
+ (let* ([name (car xt)]
+ [defd (defined (get db name 'value))] )
+ (cons name
+ (remove
+ (lambda (v)
+ (or (assq v graph)
+ (memq v defd) ) )
+ (delete-duplicates (cdr xt) eq?)) ) ) )
+ extras) ) )
+
+ (define (reconstruct! graph extra)
+ ;; Reconstruct node tree by adding global definitions:
+ (node-subexpressions-set!
+ node
+ (list
+ (fold-right
+ (lambda (gn body)
+ (let* ([name (car gn)]
+ [lval (get db name 'value)] )
+ (hide-variable name)
+ (decompose-lambda-list
+ (first (node-parameters lval))
+ (lambda (vars argc rest)
+ (let* ([xvars (cdr (assq name extra))]
+ [xaliases (map gensym xvars)]
+ [xmap (map cons xvars xaliases)] )
+ (rename-extra-variables! (first (node-subexpressions lval)) xmap)
+ (make-node
+ 'let (list (gensym 't))
+ (list (make-node
+ 'set! (list name)
+ (list
+ (make-node
+ 'lambda
+ (list (build-lambda-list (append xaliases vars) (+ argc (length xvars)) rest))
+ (node-subexpressions lval) ) ) )
+ body) ) ) ) ) ) )
+ (first (node-subexpressions node))
+ graph) ) ) )
+
+ (define (rename-extra-variables! node xmap)
+ ;; Rename variables from a given map:
+ (define (rename v)
+ (let ([a (assq v xmap)])
+ (if a (cdr a) v) ) )
+ (let walk ([n node])
+ (let ([class (node-class n)]
+ [params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case class
+ [(let)
+ (node-parameters-set! n (map rename params))
+ (for-each walk subs) ]
+ [(##core#variable)
+ (node-parameters-set! n (list (rename (first params)))) ]
+ [(set!)
+ (node-parameters-set! n (list (rename (first params))))
+ (for-each walk subs) ]
+ [(lambda)
+ (decompose-lambda-list
+ (first params)
+ (lambda (vars argc rest)
+ (set-car! params (build-lambda-list (map rename vars) argc rest))
+ (walk (first subs)) ) ) ]
+ [else (for-each walk subs)] ) ) ) )
+
+ (define (extend-call-sites! extra)
+ ;; Change call sites by adding extra variables:
+ (let walk ([n node])
+ (let ([class (node-class n)]
+ [params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case class
+ [(##core#call)
+ (let ([fn (first subs)])
+ (when (eq? '##core#variable (node-class fn))
+ (let ([a (assq (first (node-parameters fn)) extra)])
+ (when a
+ (set-car! params #t)
+ (node-subexpressions-set!
+ n
+ (cons fn (append (map varnode (cdr a)) (cdr subs))) ) ) ) )
+ (for-each walk (node-subexpressions n)) ) ]
+ [else (for-each walk subs)] ) ) ) )
+
+ (define (remove-local-bindings! graph)
+ ;; Remove local definitions of lifted procedures:
+ (let walk ([n node])
+ (let ([class (node-class n)]
+ [params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case class
+ [(let)
+ (for-each walk (node-subexpressions n))
+ (let ([vars2 '()]
+ [vals2 '()] )
+ (do ([vars params (cdr vars)]
+ [vals subs (cdr vals)] )
+ ((null? vars)
+ (cond [(null? vars2) (copy-node! (car vals) n)]
+ [else
+ (node-parameters-set! n (reverse vars2))
+ (node-subexpressions-set! n (append (reverse vals2) vals)) ] ) )
+ (unless (assq (car vars) graph)
+ (set! vars2 (cons (car vars) vars2))
+ (set! vals2 (cons (car vals) vals2)) ) ) ) ]
+ [(set!)
+ (for-each walk (node-subexpressions n))
+ (when (assq (first params) graph)
+ (node-class-set! n '##core#undefined)
+ (node-parameters-set! n '())
+ (node-subexpressions-set! n '()) ) ]
+ [else (for-each walk subs)] ) ) ) )
+
+ (debugging 'p "gathering liftables...")
+ (let ([cs (find-lifting-candidates)])
+ (debugging 'p "building call graph...")
+ (let ([g (build-call-graph cs)])
+ (debugging 'p "eliminating non-liftables...")
+ (let ([g2 (eliminate cs g)])
+ (when (debugging 'l "call-graph:") (pretty-print g2))
+ (debugging 'p "computing access-lists...")
+ (let ([al (collect-accessibles g2)])
+ (when (debugging 'l "accessibles:") (pretty-print al))
+ (debugging 'p "eliminating liftables by access-lists and non-liftable callees...")
+ (let ([ls (eliminate3 (eliminate4 g2))]) ;(eliminate2 g2 al)))]) - why isn't this used?
+ (when (pair? ls)
+ (debugging 'o "liftable local procedures" (delay (unzip1 ls))))
+ (debugging 'p "gathering extra parameters...")
+ (let ([extra (compute-extra-variables ls)])
+ (when (debugging 'l "additional parameters:") (pretty-print extra))
+ (debugging 'p "changing call sites...")
+ (extend-call-sites! extra)
+ (debugging 'p "removing local bindings...")
+ (remove-local-bindings! ls)
+ (debugging 'p "moving liftables to toplevel...")
+ (reconstruct! ls extra) ) ) ) ) ) ) ) )
diff --git a/support.scm b/support.scm
index da244319..f8b784c9 100644
--- a/support.scm
+++ b/support.scm
@@ -1282,6 +1282,7 @@ Usage: chicken FILENAME OPTION ...
-optimize-level NUMBER enable certain sets of optimization options
-optimize-leaf-routines enable leaf routine optimization
+ -lambda-lift enable lambda-lifting
-no-usual-integrations standard procedures may be redefined
-unsafe disable all safety checks
-local assume globals are only modified in current
@@ -1290,7 +1291,7 @@ Usage: chicken FILENAME OPTION ...
-disable-interrupts disable interrupts in compiled code
-fixnum-arithmetic assume all numbers are fixnums
-benchmark-mode equivalent to 'block -optimize-level 4
- -debug-level 0 -fixnum-arithmetic
+ -debug-level 0 -fixnum-arithmetic -lambda-lift
-inline -disable-interrupts'
-disable-stack-overflow-checks disables detection of stack-overflows
-inline enable inlining
Trap