~ chicken-core (chicken-5) fd7cded5eb72cc390e7cc63132d623bfd837c1d1
commit fd7cded5eb72cc390e7cc63132d623bfd837c1d1
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Dec 2 03:47:40 2010 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Dec 2 03:47:40 2010 +0100
got rid of ineffective lambda-lifter
diff --git a/batch-driver.scm b/batch-driver.scm
index 62809c9f..f86e4834 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -181,7 +181,6 @@
(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))
@@ -502,19 +501,6 @@
(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 bca49ee7..c505b932 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -84,7 +84,8 @@
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 compile-syntax tag-pointers accumulate-profile
+ lambda-lift ;XXX removed
+ 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 441bd072..cd840e07 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 'lambda-lift 'no-lambda-info
+ 'optimize-leaf-routines 'no-lambda-info
'inline 'inline-global 'unboxing
options) ) ) ) )
(loop (cdr rest)) ) )
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index f69e080b..481f5818 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -97,7 +97,6 @@
display-analysis-database
display-line-number-database
display-real-name-table
- do-lambda-lifting
do-scrutinize
dump-defined-globals
dump-global-refs
@@ -218,7 +217,6 @@
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 5ccd7894..6696c7cc 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -57,7 +57,6 @@
; (hide {<name>})
; (inline-limit <limit>)
; (keep-shadowed-macros)
-; (lambda-lift)
; (no-argc-checks)
; (no-bound-checks)
; (no-procedure-checks)
@@ -321,7 +320,6 @@
(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)
@@ -1401,7 +1399,7 @@
(for-each export-variable syms)))
((emit-external-prototypes-first)
(set! external-protos-first #t) )
- ((lambda-lift) (set! do-lambda-lifting #t))
+ ((lambda-lift) #f) ;XXX removed, remove this as well later
((inline)
(if (null? (cdr spec))
(set! inline-locally #t)
diff --git a/csc.scm b/csc.scm
index 526eeb4c..ac9ab12c 100644
--- a/csc.scm
+++ b/csc.scm
@@ -133,7 +133,8 @@
'(-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 -dynamic -disable-stack-overflow-checks -local
+ -lambda-lift ;XXX removed
+ -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
@@ -367,7 +368,6 @@ 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 8805f91f..78f8ca90 100644
--- a/manual/Declarations
+++ b/manual/Declarations
@@ -161,13 +161,6 @@ 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 8609467f..c10a7114 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -41,7 +41,6 @@ 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
@@ -50,10 +49,8 @@ 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
@@ -120,8 +117,6 @@ 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.
; -no-argc-checks : disable argument count checks
@@ -160,7 +155,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 -lambda-lift -disable-interrupts -no-trace -no-lambda-info
+ -optimize-level 5 is equivalent to -optimize-leaf-routines -block -inline -inline-global -unsafe -unboxing -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 0cdf29d9..839b6caf 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -33,8 +33,6 @@
(include "compiler-namespace")
(include "tweaks")
-(define-constant maximal-number-of-free-variables-for-liftable 16)
-
;;; Scan toplevel expressions for assignments:
@@ -1475,367 +1473,3 @@
(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 661392dc..4648afcd 100644
--- a/support.scm
+++ b/support.scm
@@ -1275,7 +1275,6 @@ 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
@@ -1284,7 +1283,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 -lambda-lift
+ -debug-level 0 -fixnum-arithmetic
-inline -disable-interrupts'
-disable-stack-overflow-checks disables detection of stack-overflows
-inline enable inlining
Trap