~ chicken-core (chicken-5) e73515a5b4e03a5e8d843cf31d8fa3d05f2290de
commit e73515a5b4e03a5e8d843cf31d8fa3d05f2290de
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Apr 11 23:05:26 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Apr 11 23:05:26 2011 +0200
trying to understand unboxing
diff --git a/scrutinizer.scm b/scrutinizer.scm
index bbd71d42..12d38aa7 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -97,6 +97,7 @@
(define (scrutinize node db complain specialize)
(let ((blist '())
(safe-calls 0))
+
(define (constant-result lit)
(cond ((string? lit) 'string)
((symbol? lit) 'symbol)
@@ -117,6 +118,7 @@
`(struct ,(##sys#slot lit 0)))
((char? lit) 'char)
(else '*)))
+
(define (global-result id loc)
(cond ((variable-mark id '##compiler#type) =>
(lambda (a)
@@ -141,6 +143,7 @@
'(*))
(else (list a)))))
(else '(*))))
+
(define (blist-type id flow)
(cond ((find (lambda (b)
(and (eq? id (caar b))
@@ -148,6 +151,7 @@
blist)
=> cdr)
(else #f)))
+
(define (variable-result id e loc flow)
(cond ((blist-type id flow) => list)
((and (get db id 'assigned)
@@ -163,11 +167,13 @@
'(*))
(else (list (cdr a))))))
(else (global-result id loc))))
+
(define (always-true1 t)
(cond ((and (pair? t) (eq? 'or (car t)))
(every always-true1 (cdr t)))
((memq t '(* boolean undefined noreturn)) #f)
(else #t)))
+
(define (always-true t loc x)
(let ((f (always-true1 t)))
(when f
@@ -178,6 +184,7 @@
t
(pp-fragment x))))
f))
+
(define (typename t)
(case t
((*) "anything")
@@ -200,6 +207,7 @@
(sprintf "a structure of type ~a" (cadr t)))
(else (bomb "invalid type: ~a" t))))
(else (bomb "invalid type: ~a" t))))))
+
(define (argument-string args)
(let* ((len (length args))
(m (multiples len)))
@@ -209,6 +217,7 @@
"~a argument~a of type~a ~a"
len m m
(map typename args)))))
+
(define (result-string results)
(if (eq? '* results)
"an unknown number of values"
@@ -220,10 +229,12 @@
"~a value~a of type~a ~a"
len m m
(map typename results))))))
+
(define (simplify t)
(let ((t2 (simplify1 t)))
(dd "simplify: ~a -> ~a" t t2)
t2))
+
(define (simplify1 t)
(call/cc
(lambda (return)
@@ -284,6 +295,7 @@
(map simplify rtypes)))))
(else t))
t))))
+
(define (merge-argument-types ts1 ts2)
(cond ((null? ts1)
(cond ((null? ts2) '())
@@ -304,16 +316,19 @@
(else '(#!rest)))) ;XXX
(else (cons (simplify `(or ,(car ts1) ,(car ts2)))
(merge-argument-types (cdr ts1) (cdr ts2))))))
+
(define (merge-result-types ts1 ts2) ;XXX possibly overly conservative
(cond ((null? ts1) ts2)
((null? ts2) ts1)
((or (atom? ts1) (atom? ts2)) '*)
(else (cons (simplify `(or ,(car ts1) ,(car ts2)))
(merge-result-types (cdr ts1) (cdr ts2))))))
+
(define (match t1 t2)
(let ((m (match1 t1 t2)))
(dd " match ~a <-> ~a -> ~a" t1 t2 m)
m))
+
(define (match1 t1 t2)
(cond ((eq? t1 t2))
((eq? t1 '*))
@@ -340,6 +355,7 @@
((struct) (equal? t1 t2))
(else #f) ) )
(else #f)))
+
(define (match-args args1 args2)
(d "match-args: ~s <-> ~s" args1 args2)
(define (match-rest rtype args opt) ;XXX currently ignores `opt'
@@ -367,6 +383,7 @@
(match-rest (rest-type (cdr args2)) args1 opt1))
((match (car args1) (car args2)) (loop (cdr args1) (cdr args2) opt1 opt2))
(else #f))))
+
(define (match-results results1 results2)
(cond ((null? results1) (atom? results2))
((eq? '* results1))
@@ -375,8 +392,10 @@
((match (car results1) (car results2))
(match-results (cdr results1) (cdr results2)))
(else #f)))
+
(define (multiples n)
(if (= n 1) "" "s"))
+
(define (single what tv loc)
(if (eq? '* tv)
'*
@@ -393,10 +412,12 @@
(sprintf "expected ~a a single result, but were given ~a result~a"
what n (multiples n)))
(first tv))))))
+
(define (report loc desc #!optional (show complain))
(when show
(warning
(conc (location-name loc) desc))))
+
(define (location-name loc)
(define (lname loc1)
(if loc1
@@ -410,7 +431,9 @@
(if (null? (cdr loc))
(location-name loc)
(sprintf "in local ~a,\n ~a" (lname (car loc)) (rec (cdr loc))))))))
+
(define add-loc cons)
+
(define (fragment x)
(let ((x (build-expression-tree x)))
(let walk ((x x) (d 0))
@@ -419,11 +442,13 @@
((list? x)
(map (cute walk <> (add1 d)) (take x (min +fragment-max-length+ (length x)))))
(else x)))))
+
(define (pp-fragment x)
(string-chomp
(with-output-to-string
(lambda ()
(pp (fragment x))))))
+
(define (call-result node args e loc params)
(define (pname)
(sprintf "~ain procedure call to `~s', "
@@ -521,6 +546,7 @@
(set! safe-calls (add1 safe-calls))))
(d " result-types: ~a" r)
r))))
+
(define (self-call? node loc)
(case (node-class node)
((##core#call)
@@ -531,11 +557,13 @@
((let)
(self-call? (last (node-subexpressions node)) loc))
(else #f)))
+
(define tag
(let ((n 0))
(lambda ()
(set! n (add1 n))
n)))
+
(define (invalidate-blist)
(for-each
(lambda (b)
@@ -547,6 +575,7 @@
(dd "invalidating: ~a" b)
(set-cdr! b '*))))
blist))
+
(define (walk n e loc dest tail flow ctags) ; returns result specifier
(let ((subs (node-subexpressions n))
(params (node-parameters n))
@@ -743,6 +772,7 @@
(set! d-depth (sub1 d-depth))
(dd " -> ~a" results)
results)))
+
(let ((rn (walk (first (node-subexpressions node)) '() '() #f #f (list (tag)) #f)))
(when (and (pair? specialization-statistics)
(debugging 'x "specializations:"))
diff --git a/unboxing.scm b/unboxing.scm
index 961dc9cc..e668e9de 100644
--- a/unboxing.scm
+++ b/unboxing.scm
@@ -24,16 +24,20 @@
; POSSIBILITY OF SUCH DAMAGE.
-(declare (unit unboxing))
+(declare
+ (unit unboxing)
+ (hide d-depth))
(include "compiler-namespace")
(include "tweaks")
+(define d-depth 0)
+
(define (d fstr . args)
(when (##sys#fudge 13)
- (printf "[debug] ~?~%" fstr args)) )
+ (printf "[debug] ~a~?~%" (make-string d-depth #\space) fstr args)) )
;(define-syntax d (syntax-rules () ((_ . _) (void))))
@@ -46,7 +50,7 @@
(define (walk-lambda id e body)
(let ((ae '()))
- (define (boxed! v) ; 'boxed is sticky
+ (define (boxed! v) ; boxed is sticky
(d "boxing ~a" v )
(cond ((assq v e) =>
(lambda (a)
@@ -74,13 +78,14 @@
(define (unboxed-value? x)
(and x (cdr x)))
- (define (invalidate r) ; if result is variable, mark it 'boxed
+ (define (invalidate r) ; if result is variable, mark it boxed
(when (and (pair? r) (car r))
(boxed! (car r))))
(define (alias v)
(alist-ref v ae eq? v) )
+ ;; merge results at control-flow join (i.e. conditional)
(define (merge r1 r2)
(cond ((or (not r1) (not (cdr r1)))
(invalidate r2)
@@ -105,7 +110,6 @@
(let ((n2 (make-node
'##core#inline_unboxed (list alt)
(reverse iargs))))
- ;(pp (build-expression-tree n2))
(if (and dest (cdr dest))
n2
(let ((tmp (gensym "tu")))
@@ -136,7 +140,8 @@
((bool)
(make-node
'##core#inline '("C_mk_bool")
- (list (make-node '##core#unboxed_ref (list tmp rtype) '()))))
+ (list
+ (make-node '##core#unboxed_ref (list tmp rtype) '()))))
((*) (bomb "unboxed type `*' not allowed as result"))
(else (bomb "invalid unboxed type" rtype)))))))))
((or (eq? (car atypes) '*)
@@ -146,7 +151,14 @@
(cdr atypes)
(cons (car anodes) iargs)))
(else
- ;; introduce unboxed temporary
+ ;; introduce unboxed temporary for argument
+ ;;
+ ;;XXX this is suboptimal: we could reuse unboxed temporaries
+ ;; that are in scope. Currently the same are will be unboxed
+ ;; repeatedly.
+ ;; (But we must make sure there are not intermediate side
+ ;; effects - possibly only reuse unboxed value if unassigned
+ ;; local or lexical variable ref, or literal)
(let ((tmp (gensym "tu")))
(make-node
'##core#let_unboxed (list tmp (car atypes))
@@ -160,7 +172,8 @@
((pointer) "C_pointer_address")
((bool) "C_truep")
((*) "C_id")
- (else (bomb "invalid unboxed argument type" (car atypes)))))
+ (else
+ (bomb "invalid unboxed argument type" (car atypes)))))
(list (car anodes)))
(loop (cdr args)
(cdr anodes)
@@ -255,134 +268,145 @@
n))
n))
+ ;; walk node and return either "(<var> . <type>)" or #f
+ ;; - at second pass: rewrite "##core#inline[_allocate]" nodes
(define (walk n dest udest pass2?)
(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#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 rw1
- (or unsafe
- (and (fourth rw1)
- unchecked-specialized-arithmetic))
- 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 rw1
+ (or unsafe
+ (and (fourth rw1)
+ unchecked-specialized-arithmetic))
+ 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
+ (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))))
+ (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))))
+ (set! d-depth (sub1 d-depth))
+ result)))
(d "walk lambda: ~a (pass 1)" id)
;; walk once and mark boxed/unboxed variables in environment
Trap