~ chicken-core (chicken-5) 7a9d96def782128ec33db66b2319c6e14d42806c
commit 7a9d96def782128ec33db66b2319c6e14d42806c
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jul 15 16:07:55 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Jul 15 16:07:55 2011 +0200
enabled linear-cc again
diff --git a/compiler.scm b/compiler.scm
index 7fc629d7..3e5b6b35 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -4,7 +4,7 @@
; "This is insane. What we clearly want to do is not exactly clear, and is rooted in NCOMPLR."
;
;
-;--------------------------------------------------------------------------------------------------
+;--------------------------------------------------------------------------------------------
; Copyright (c) 2008-2011, The Chicken Team
; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
@@ -2105,11 +2105,13 @@
;;; Collect unsafe global procedure calls that are assigned:
-;;; Convert closures to explicit data structures (effectively flattens function-binding structure):
+;;; Convert closures to explicit data structures (effectively flattens function-binding
+; structure):
(define (perform-closure-conversion node db)
- (let ([direct-calls 0]
- [customizable '()] )
+ (let ((direct-calls 0)
+ (customizable '())
+ (lexicals '()))
(define (test sym item) (get db sym item))
@@ -2124,17 +2126,33 @@
;; Gather free-variable information:
;; (and: - register direct calls
;; - update (by mutation) call information in "##core#call" nodes)
- (define (gather n here env)
+ (define (gather n here locals)
(let ((subs (node-subexpressions n))
(params (node-parameters n)) )
(case (node-class n)
- ((quote ##core#variable ##core#undefined ##core#proc ##core#primitive ##core#global-ref) #f)
+ ((##core#variable)
+ (let ((var (first params)))
+ (if (memq var lexicals)
+ (list var)
+ '())))
+
+ ((quote ##core#undefined ##core#proc ##core#primitive ##core#global-ref)
+ '())
((let)
- (receive (vals body) (split-at subs (length params))
- (for-each (lambda (n) (gather n here env)) vals)
- (gather (first body) here (append params env)) ) )
+ ;;XXX remove this test later, shouldn't be needed:
+ (when (pair? (cdr params)) (bomb "let-node has invalid format" params))
+ (let ((c (gather (first subs) here locals))
+ (var (first params)))
+ (append c (delete var (gather (second subs) here (cons var locals)) eq?))))
+
+ ((set!)
+ (let ((var (first params))
+ (c (gather (first subs) here locals)))
+ (if (memq var lexicals)
+ (cons var c)
+ c)))
((##core#call)
(let* ([fn (first subs)]
@@ -2178,7 +2196,7 @@
'() ) )
'() ) )
'() ) ) )
- (for-each (lambda (n) (gather n here env)) subs) ) )
+ (concatenate (map (lambda (n) (gather n here locals)) subs) ) ))
((##core#lambda ##core#direct_lambda)
(decompose-lambda-list
@@ -2191,7 +2209,7 @@
(put! db id 'captured-variables c)
(lset-difference eq? c locals vars)))))))
- (else (for-each (lambda (n) (gather n here env)) subs)) ) ) )
+ (else (concatenate (map (lambda (n) (gather n here locals)) subs)) ) ) ))
;; Create explicit closures:
(define (transform n here closure)
@@ -2339,24 +2357,6 @@
(list (varnode here)) ) ) )
(else n) ) ) )
- (define (captured-variables node env)
- (let ([vars '()])
- (let walk ([n node])
- (let ((subs (node-subexpressions n))
- (params (node-parameters n)) )
- (case (node-class n)
- ((##core#variable)
- (let ([var (first params)])
- (when (memq var env)
- (set! vars (lset-adjoin eq? vars var)) ) ) )
- ((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref ##core#global-ref) #f)
- ((set!)
- (let ([var (first params)])
- (when (memq var env) (set! vars (lset-adjoin eq? vars var)))
- (walk (car subs)) ) )
- (else (for-each walk subs)) ) ) )
- vars) )
-
(debugging 'p "closure conversion gathering phase...")
(gather node #f '())
(when (pair? customizable)
Trap