~ chicken-core (chicken-5) 2dec666b1f0f68a312f7d211ace18c09293d23e7
commit 2dec666b1f0f68a312f7d211ace18c09293d23e7
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Sep 21 07:51:59 2010 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Sep 21 07:51:59 2010 -0400
abort inlining if body refers to contractable
diff --git a/optimizer.scm b/optimizer.scm
index 65d87343..a28801cf 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -287,7 +287,9 @@
(touch)
(for-each (cut put! db <> 'inline-target #t) fids)
(walk
- (inline-lambda-bindings llist args (first (node-subexpressions lval)) #f db)
+ (inline-lambda-bindings
+ llist args (first (node-subexpressions lval)) #f db
+ void)
fids) ) )
((variable-mark var '##compiler#pure) =>
(lambda (pb)
@@ -339,10 +341,19 @@
(for-each (cut put! db <> 'inline-target #t) fids)
(check-signature var args llist)
(debugging 'o "inlining procedure" var)
- (touch)
- (walk
- (inline-lambda-bindings llist args (first (node-subexpressions lval)) #t db)
- fids) )
+ (call/cc
+ (lambda (return)
+ (define (cfk cvar)
+ (debugging
+ 'i
+ "not inlining procedure because it refers to contractable"
+ var cvar)
+ (return (walk-generic n class params subs fids)))
+ (let ((n2 (inline-lambda-bindings
+ llist args (first (node-subexpressions lval)) #t db
+ cfk)))
+ (touch)
+ (walk n2 fids)))))
((test ifid 'has-unused-parameters)
(if (< (length args) argc) ; Expression was already optimized (should this happen?)
(walk-generic n class params subs fids)
@@ -403,9 +414,13 @@
((set!)
(let ([var (first params)])
- (cond [(or (test var 'contractable) (test var 'replacable))
+ (cond ((test var 'contractable)
(touch)
- (make-node '##core#undefined '() '()) ]
+ (debugging 'i "removing global contractable" var)
+ (make-node '##core#undefined '() '()) )
+ ((test var 'replacable)
+ (touch)
+ (make-node '##core#undefined '() '()) )
[(and (or (not (test var 'global))
(not (variable-visible? var)))
(not (test var 'inline-transient))
diff --git a/support.scm b/support.scm
index 143ef741..9f5855f0 100644
--- a/support.scm
+++ b/support.scm
@@ -576,14 +576,14 @@
(list (proc (first vars) (second vars))
(fold (cdr vars)) ) ) ) ) )
-(define (inline-lambda-bindings llist args body copy? db)
+(define (inline-lambda-bindings llist args body copy? db cfk)
(decompose-lambda-list
llist
(lambda (vars argc rest)
(receive (largs rargs) (split-at args argc)
(let* ([rlist (if copy? (map gensym vars) vars)]
[body (if copy?
- (copy-node-tree-and-rename body vars rlist db)
+ (copy-node-tree-and-rename body vars rlist db cfk)
body) ] )
(fold-right
(lambda (var val body) (make-node 'let (list var) (list val body)) )
@@ -598,7 +598,7 @@
(take rlist argc)
largs) ) ) ) ) )
-(define (copy-node-tree-and-rename node vars aliases db)
+(define (copy-node-tree-and-rename node vars aliases db cfk)
(let ([rlist (map cons vars aliases)])
(define (rename v rl) (alist-ref v rl eq? v))
(define (walk n rl)
@@ -611,7 +611,7 @@
[(##core#variable)
(let ((var (first params)))
(when (get db var 'contractable)
- (put! db var 'contractable #f) )
+ (cfk var))
(varnode (rename var rl))) ]
[(set!)
(make-node
Trap