suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fixed a bug that caused the let optimizations to choke on TR-introduced code.

Browse Source
This commit is contained in:
Vincent St-Amour 2010-07-29 11:50:40 -04:00
parent f08456cf07
commit b58461da2d
1 changed files with 44 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
collects/typed-scheme/optimizer/unboxed-let.rkt
View File

@ -66,46 +66,50 @@
;; this covers loop variables ;; this covers loop variables
(partition (partition
(lambda (p) (lambda (p)
(let ((fun-name (car (syntax-e (car p))))) (and
(and ;; typed racket introduces let-values that bind no values
;; if the function escapes, we can't change it's interface ;; we can't optimize these
(not (is-var-mutated? fun-name)) (not (null? (syntax-e (car p))))
(not (escapes? fun-name #'(begin body ...) let-loop?)) (let ((fun-name (car (syntax-e (car p)))))
(match (type-of (cadr p)) ; rhs, we want a lambda (and
[(tc-result1: (Function: (list (arr: doms rngs ;; if the function escapes, we can't change it's interface
(and rests #f) (not (is-var-mutated? fun-name))
(and drests #f) (not (escapes? fun-name #'(begin body ...) let-loop?))
(and kws '()))))) (match (type-of (cadr p)) ; rhs, we want a lambda
;; at least 1 argument has to be of type inexact-complex [(tc-result1: (Function: (list (arr: doms rngs
;; and can be unboxed (and rests #f)
(syntax-parse (cadr p) (and drests #f)
[(#%plain-lambda params body ...) (and kws '())))))
;; keep track of the param # of each param that can be unboxed ;; at least 1 argument has to be of type inexact-complex
(let loop ((unboxed '()) ;; and can be unboxed
(boxed '()) (syntax-parse (cadr p)
(i 0) [(#%plain-lambda params body ...)
(params (syntax->list #'params)) ;; keep track of the param # of each param that can be unboxed
(doms doms)) (let loop ((unboxed '())
(cond [(null? params) (boxed '())
;; done. can we unbox anything? (i 0)
(and (> (length unboxed) 0) (params (syntax->list #'params))
;; if so, add to the table of functions with (doms doms))
;; unboxed params, so we can modify its call (cond [(null? params)
;; sites, it's body and its header ;; done. can we unbox anything?
(dict-set! unboxed-funs-table fun-name (and (> (length unboxed) 0)
(list (reverse unboxed) ;; if so, add to the table of functions with
(reverse boxed))))] ;; unboxed params, so we can modify its call
[(and (equal? (car doms) -InexactComplex) ;; sites, it's body and its header
(could-be-unboxed-in? (dict-set! unboxed-funs-table fun-name
(car params) #'(begin body ...))) (list (reverse unboxed)
;; we can unbox (reverse boxed))))]
(loop (cons i unboxed) boxed [(and (equal? (car doms) -InexactComplex)
(add1 i) (cdr params) (cdr doms))] (could-be-unboxed-in?
[else ; can't unbox (car params) #'(begin body ...)))
(loop unboxed (cons i boxed) ;; we can unbox
(add1 i) (cdr params) (cdr doms))]))] (loop (cons i unboxed) boxed
[_ #f])] (add1 i) (cdr params) (cdr doms))]
[_ #f])))) [else ; can't unbox
(loop unboxed (cons i boxed)
(add1 i) (cdr params) (cdr doms))]))]
[_ #f])]
[_ #f])))))
rest))) rest)))
(list candidates function-candidates others)) (list candidates function-candidates others))
#:with (opt-candidates:unboxed-let-clause ...) #'(candidates ...) #:with (opt-candidates:unboxed-let-clause ...) #'(candidates ...)