~ chicken-core (chicken-5) 57a7bf7103c4e21ed83ff4b6876a2b13d22163ec
commit 57a7bf7103c4e21ed83ff4b6876a2b13d22163ec
Merge: ac843dd5 1eff1721
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Aug 5 10:04:12 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Aug 5 10:04:12 2011 +0200
resolved conflicts
diff --cc compiler.scm
index 0e1bd1d2,7a6d8e95..b7ca7b03
--- a/compiler.scm
+++ b/compiler.scm
@@@ -1647,10 -1599,10 +1645,10 @@@
(params (node-parameters n))
(class (node-class n)) )
(case (node-class n)
- ((##core#variable quote ##core#undefined ##core#primitive ##core#global-ref) (k n))
+ ((##core#variable quote ##core#undefined ##core#primitive) (k n))
((if) (let* ((t1 (gensym 'k))
(t2 (gensym 'r))
- (k1 (lambda (r) (make-node '##core#call '(#t) (list (varnode t1) r)))) )
+ (k1 (lambda (r) (make-node '##core#call (list #t) (list (varnode t1) r)))) )
(make-node
'let
(list t1)
@@@ -1742,9 -1691,9 +1740,10 @@@
(define (atomic? n)
(let ((class (node-class n)))
- (or (memq class '(quote ##core#variable ##core#undefined ##core#global-ref))
- (and (memq class '(##core#inline_ref ##core#inline_update ##core#inline_loc_ref
- ##core#inline_loc_update))
+ (or (memq class '(quote ##core#variable ##core#undefined))
- (and (memq class '(##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update
- ##core#inline_loc_ref ##core#inline_loc_update))
++ (and (memq class '(##core#inline_allocate
++ ##core#inline_ref ##core#inline_update
++ ##core#inline_loc_ref ##core#inline_loc_update))
(every atomic? (node-subexpressions n)) ) ) ) )
(walk node values) )
diff --cc library.scm
index 0abf2dfa,6399e284..163fff10
--- a/library.scm
+++ b/library.scm
@@@ -2196,20 -2166,26 +2195,27 @@@ EO
(set! count (fx+ count 1))
(when (fx>= i (##sys#size ##sys#default-parameter-vector))
(set! ##sys#default-parameter-vector
- (##sys#grow-vector ##sys#default-parameter-vector (fx+ i 1) (##core#undefined)) ) )
+ (##sys#grow-vector
+ ##sys#default-parameter-vector
+ (fx+ i 1)
+ (##core#undefined)) ) )
(##sys#setslot ##sys#default-parameter-vector i val)
(let ((assign
- (lambda (val n)
+ (lambda (val n mode)
(when (fx>= i n)
(set! ##sys#current-parameter-vector
- (##sys#grow-vector ##sys#current-parameter-vector (fx+ i 1) ##sys#snafu) ) )
- (let ((val (guard val)))
+ (##sys#grow-vector
+ ##sys#current-parameter-vector
+ (fx+ i 1)
+ ##sys#snafu) ) )
- (##sys#setslot ##sys#current-parameter-vector i (if mode val (guard val)))
- (##core#undefined) )))
++ (let ((val (if mode val (guard val))))
+ (##sys#setslot ##sys#current-parameter-vector i val)
+ val))))
(getter-with-setter
- (lambda arg
+ (lambda args
(let ((n (##sys#size ##sys#current-parameter-vector)))
- (cond ((pair? arg) (assign (car arg) n))
+ (cond ((pair? args)
+ (assign (car args) n (optional (cdr args) #f)))
((fx>= i n)
(##sys#slot ##sys#default-parameter-vector i) )
(else
diff --cc optimizer.scm
index 9d29e0d9,dd380cc2..1e30ed43
--- a/optimizer.scm
+++ b/optimizer.scm
@@@ -313,9 -334,9 +334,9 @@@
"removed call to pure procedure with unused result"
(or (source-info->string info) var)))
(make-node
- '##core#call '(#t)
+ '##core#call (list #t)
(list k (make-node '##core#undefined '() '())) ) )
- (walk-generic n class params subs fids)) ) )
+ (walk-generic n class params subs fids gae #f)) ) )
((and lval
(eq? '##core#lambda (node-class lval)))
(let* ([lparams (node-parameters lval)]
diff --cc unboxing.scm
index 83221d25,85abda21..94e2e8c4
--- a/unboxing.scm
+++ b/unboxing.scm
@@@ -352,159 -255,129 +352,158 @@@
(let ((subs (node-subexpressions n))
(params (node-parameters n))
(class (node-class n)) )
- (d "walk: (~a) ~a ~a" pass2? class params)
- (case class
-
- ((##core#undefined
- ##core#proc
- ##core#inline_ref
- ##core#inline_loc_ref) #f)
-
- ((##core#lambda ##core#direct_lambda)
- (decompose-lambda-list
- (third params)
- (lambda (vars argc rest)
- (unless pass2?
- (walk-lambda
- (first params)
- (map (cut cons <> #f) vars)
- (first subs)) )
- #f)))
-
- ((##core#variable)
- (let* ((v (first params))
- (a (assq v e)))
- (cond (pass2?
- (when (and a (cdr a))
- (copy-node!
- (make-node '##core#unboxed_ref (list (alias v) (cdr a)) '())
- n)))
- ((not a) #f) ; global
- ((not udest) (boxed! v)))
- a))
-
- ((##core#inline ##core#inline_allocate)
- (let* ((rw1 (##sys#get (symbolify (first params)) '##compiler#unboxed-op))
- (rw (and unsafe rw1))
- (args (map (cut walk <> #f rw pass2?) subs)))
- (cond ((not rw) #f)
- ((or (not pass2?)
- (and dest (unboxed? dest))
- (any unboxed-value? args))
- (let ((alt (first rw))
- (atypes (second rw))
- (rtype (third rw)))
- ;; result or arguments are unboxed - rewrite node to alternative
+ (d "walk: (~a) ~a ~a" (if pass2? 2 1) class params)
+ (set! d-depth (add1 d-depth))
+ (let ((result
+ (case class
+
+ ((##core#undefined
+ ##core#proc
- ##core#global-ref
+ ##core#inline_ref
+ ##core#inline_loc_ref) #f)
+
+ ((##core#lambda ##core#direct_lambda)
+ (decompose-lambda-list
+ (third params)
+ (lambda (vars argc rest)
+ (unless pass2?
+ (walk-lambda
+ (first params)
+ (map (cut cons <> #f) vars)
+ (first subs)) )
+ #f)))
+
+ ((##core#variable)
+ (let* ((v (first params))
+ (a (assq v e)))
+ (cond (pass2?
+ (when (and a (cdr a))
+ (copy-node!
+ (make-node
+ '##core#unboxed_ref
+ (list (alias v) (cdr a))
+ '())
+ n)))
+ ((not a) #f) ; global
+ ((not udest) (boxed! v)))
+ a))
+
+ ((##core#inline ##core#inline_allocate)
+ (let* ((rw1 (##sys#get
+ (symbolify (first params))
+ '##compiler#unboxed-op))
+ (rw (and unsafe rw1))
+ (args (map (cut walk <> #f rw pass2?) subs)))
+ ;; rewrite inline operation to unboxed one, if possible
+ (cond ((not rw) #f)
+ ((or (not pass2?)
+ (and dest (unboxed? dest))
+ (any unboxed-value? args))
+ (let ((alt (first rw))
+ (atypes (second rw))
+ (rtype (third rw)))
+ ;; result or arguments are unboxed - rewrite node to alternative
+ (when pass2?
+ (rewrite!
+ n alt subs args atypes rtype
+ (and dest (assq dest e))))
+ (cons #f rtype)) )
+ (else
+ (let ((rtype (third rw)))
+ ;; mark argument-vars and dest as unboxed if alternative exists
+ (unless pass2?
+ (for-each
+ (lambda (a)
+ (when (and a (car a) (cdr a))
+ (unboxed! (car a) (cdr a))))
+ args)
+ (when dest
+ (unboxed! dest rtype)))
+ (cons #f rtype))))))
+
+ ((let)
+ (let* ((v (first params))
+ (r1 (walk (first subs) v #t pass2?)))
+ (when (and (not pass2?) r1 (cdr r1))
+ (unboxed! (first params) (cdr r1)))
+ (let ((r (walk (second subs) dest udest pass2?)))
(when pass2?
- (rewrite!
- n alt subs args atypes rtype
- (and dest (assq dest e))))
- (cons #f rtype)) )
- (else
- (let ((rtype (third rw)))
- ;; mark argument-vars and dest as unboxed if alternative exists
- (unless pass2?
- (for-each
- (lambda (a)
- (when (and a (car a) (cdr a))
- (unboxed! (car a) (cdr a))))
- args)
- (when dest
- (unboxed! dest rtype)))
- (cons #f rtype))))))
-
- ((let)
- (let* ((v (first params))
- (r1 (walk (first subs) v #t pass2?)))
- (when (and (not pass2?) r1 (cdr r1))
- (unboxed! (first params) (cdr r1)))
- (let ((r (walk (second subs) dest udest pass2?)))
- (when pass2?
- (let ((a (assq v e)))
- (if (and a (cdr a))
- (rebind-unboxed! n (cdr a))
- (straighten-binding! n))) )
- r)))
-
- ((set!)
- (let* ((var (first params))
- (a (assq var e))
- (val (walk (first subs) var (and a (cdr a)) pass2?)))
- (cond (pass2?
- (when (and a (cdr a)) ; may have mutated
- (copy-node!
- (make-node
- '##core#unboxed_set! (list (alias var) (cdr a)) subs)
- n)))
- ((and val (cdr val))
- (unboxed! var (cdr val)))
- (else
- (boxed! var)
- (invalidate val) ) )
- #f))
-
- ((quote) #f)
-
- ((if ##core#cond)
- (invalidate (walk (first subs) #f #f pass2?))
- (straighten-conditional! n)
- (let ((r1 (walk (second subs) dest udest pass2?))
- (r2 (walk (third subs) dest udest pass2?)))
- (merge r1 r2)))
-
- ((##core#switch)
- (invalidate (walk (first subs) #f #f pass2?))
- (do ((clauses (cdr subs) (cddr clauses))
- (r 'none
- (if (eq? r 'none)
- (walk (second clauses) dest udest pass2?)
- (merge r (walk (second clauses) dest udest pass2?)))))
- ((null? (cdr clauses))
- (merge r (walk (car clauses) dest udest pass2?))) ) )
-
- ((##core#call ##core#direct_call)
- (for-each (o invalidate (cut walk <> #f #f pass2?)) subs)
- (when pass2?
- (straighten-call! n))
- #f)
-
- (else
- (for-each (o invalidate (cut walk <> #f #f pass2?)) subs)
- #f))))
-
- (d "walk lambda: ~a" id)
+ (let ((a (assq v e)))
+ (if (and a (cdr a))
+ (rebind-unboxed! n (cdr a))
+ (straighten-binding! n))))
+ r)))
+
+ ((set!)
+ (let* ((var (first params))
+ (a (assq var e))
+ (val (walk (first subs) var (and a (cdr a)) pass2?)))
+ (cond (pass2?
+ (cond ((and a (cdr a)) ; may have mutated in walk above
+ (copy-node!
+ (make-node
+ '##core#unboxed_set! (list (alias var) (cdr a)) subs)
+ n)
+ (straighten-unboxed-assignment! n))
+ (else
+ (straighten-assignment! n))))
+ ((and a val (cdr val))
+ (unboxed! var (cdr val)))
+ (else
+ (boxed! var)
+ (invalidate val) ) )
+ #f))
+
+ ((quote) #f)
+
+ ((if ##core#cond)
+ (invalidate (walk (first subs) #f #f pass2?))
+ (straighten-conditional! n)
+ (let ((r1 (walk (second subs) dest udest pass2?))
+ (r2 (walk (third subs) dest udest pass2?)))
+ (merge r1 r2)))
+
+ ((##core#switch)
+ (invalidate (walk (first subs) #f #f pass2?))
+ (do ((clauses (cdr subs) (cddr clauses))
+ (r 'none
+ (if (eq? r 'none)
+ (walk (second clauses) dest udest pass2?)
+ (merge r (walk (second clauses) dest udest pass2?)))))
+ ((null? (cdr clauses))
+ (merge r (walk (car clauses) dest udest pass2?))) ) )
+
+ ((##core#call ##core#direct_call)
+ (for-each (o invalidate (cut walk <> #f #f pass2?)) subs)
+ (when pass2?
+ (straighten-call! n))
+ #f)
+
+ (else
+ (for-each (o invalidate (cut walk <> #f #f pass2?)) subs)
+ #f))))
+
+ (set! d-depth (sub1 d-depth))
+ result)))
+
+ (d "walk lambda: ~a (pass 1)" id)
+ ;; walk once and mark boxed/unboxed variables in environment
(walk body #f #f #f)
+ ;; walk a second time and rewrite
+ (d "walk lambda: ~a (pass 2)" id)
(walk body #f #f #t)))
+
+ ;;XXX Note: lexical references ("##core#ref" nodes) are unboxed
+ ;; repeatedly which is sub-optimal: the unboxed temporaries bound
+ ;; via "##core#let_unboxed" could be re-used in many cases.
+ ;; One possible approach would be an additional "cleanup" pass
+ ;; that replaces
+ ;;
+ ;; (##core#let_unboxed (TU TYPE) X (##core#ref VAR (SLOT)) Y)
+ ;;
+ ;; with
+ ;;
+ ;; (##core#let_unboxed (TU TYPE) (##core#unboxed_ref TU1) Y)
(walk-lambda #f '() node)
(when (and any-rewrites
Trap