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

Improved logging since it's now used for testing.

Browse Source 
original commit: ca16ac4db50032324c2886766f477909f38b983c
This commit is contained in:
Vincent St-Amour 2010-08-27 12:22:19 -04:00
parent 5169f42b28
commit 31342660e4
4 changed files with 42 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/typed-scheme/optimizer/inexact-complex.rkt
View File

@ -229,7 +229,7 @@
#:with real-binding #'c.real-binding
#:with imag-binding #f
#:with (bindings ...)
(begin (log-optimization "unboxed unary inexact complex**" #'op)
(begin (log-optimization "unboxed unary inexact complex" #'op)
#'(c.bindings ...)))
(pattern (#%plain-app (~and op (~or (~literal imag-part) (~literal unsafe-flimag-part)))
c:unboxed-inexact-complex-opt-expr)
@ -244,7 +244,7 @@
(pattern e:float-coerce-expr
#:with real-binding (unboxed-gensym 'unboxed-float-)
#:with imag-binding #f
#:when (log-optimization "float-coerce-expr" #'e)
#:when (log-optimization "float-coerce-expr in complex ops" #'e)
#:with (bindings ...)
#`(((real-binding) e.opt)))
@ -278,7 +278,9 @@
#:when (syntax->datum #'unboxed-info)
#:with real-binding (car (syntax->list #'unboxed-info))
#:with imag-binding (cadr (syntax->list #'unboxed-info))
#:with (bindings ...) #'())
#:with (bindings ...)
(begin (log-optimization "leave var unboxed" #'v)
#'()))
;; else, do the unboxing here
@ -290,21 +292,23 @@
#:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...)
(let ((n (syntax->datum #'n)))
#`(((real-binding) #,(datum->syntax
#'here
(exact->inexact (real-part n))))
((imag-binding) #,(datum->syntax
#'here
(exact->inexact (imag-part n)))))))
(begin (log-optimization "unboxed literal" #'n)
(let ((n (syntax->datum #'n)))
#`(((real-binding) #,(datum->syntax
#'here
(exact->inexact (real-part n))))
((imag-binding) #,(datum->syntax
#'here
(exact->inexact (imag-part n))))))))
(pattern (quote n)
#:when (real? (syntax->datum #'n))
#:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding #f
#:with (bindings ...)
#`(((real-binding) #,(datum->syntax
#'here
(exact->inexact (syntax->datum #'n))))))
(begin (log-optimization "unboxed literal" #'n)
#`(((real-binding) #,(datum->syntax
#'here
(exact->inexact (syntax->datum #'n)))))))
(pattern e:expr
#:when (isoftype? #'e -InexactComplex)
@ -312,18 +316,20 @@
#:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...)
#`(((e*) #,((optimize) #'e))
((real-binding) (unsafe-flreal-part e*))
((imag-binding) (unsafe-flimag-part e*))))
(begin (log-optimization "unbox inexact-complex" #'e)
#`(((e*) #,((optimize) #'e))
((real-binding) (unsafe-flreal-part e*))
((imag-binding) (unsafe-flimag-part e*)))))
(pattern e:expr
#:when (isoftype? #'e -Number) ; complex, maybe exact, maybe not
#:with e* (unboxed-gensym)
#:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...)
#`(((e*) #,((optimize) #'e))
((real-binding) (exact->inexact (real-part e*)))
((imag-binding) (exact->inexact (imag-part e*)))))
(begin (log-optimization "unbox complex" #'e)
#`(((e*) #,((optimize) #'e))
((real-binding) (exact->inexact (real-part e*)))
((imag-binding) (exact->inexact (imag-part e*))))))
(pattern e:expr
#:with (bindings ...)
(error "non exhaustive pattern match")
@ -387,7 +393,8 @@
#'unboxed-info #'op)) ; no need to optimize op
#'e
#:with opt
#'e*.opt)
(begin (log-optimization "call to fun with unboxed args" #'op)
#'e*.opt))
(pattern e:inexact-complex-arith-opt-expr
#:with opt #'e.opt))
@ -427,7 +434,7 @@
#:with (bindings ...) #'()
;; unboxed variable used in a boxed fashion, we have to box
#:with opt
(begin (log-optimization "unboxed complex variable " #'v)
(begin (log-optimization "unboxed complex variable" #'v)
(reset-unboxed-gensym)
#'(unsafe-make-flrectangular real-binding imag-binding))))

4
collects/typed-scheme/optimizer/string.rkt
View File

@ -20,9 +20,9 @@
(define-syntax-class string-opt-expr
(pattern (#%plain-app (~literal string-length) s:string-expr)
#:with opt
(begin (log-optimization "string" #'op)
(begin (log-optimization "string-length" #'op)
#'(unsafe-string-length s.opt)))
(pattern (#%plain-app (~literal bytes-length) s:bytes-expr)
#:with opt
(begin (log-optimization "bytes" #'op)
(begin (log-optimization "bytes-length" #'op)
#'(unsafe-bytes-length s.opt))))

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

@ -38,7 +38,8 @@
#'unboxed-info #'operator.opt))
#'e
#:with opt
#'e*.opt))
(begin (log-optimization "unboxed let loop" #'loop-fun)
#'e*.opt)))
;; does the bulk of the work
;; detects which let bindings can be unboxed, same for arguments of let-bound
@ -98,6 +99,10 @@
;; if so, add to the table of functions with
;; unboxed params, so we can modify its call
;; sites, it's body and its header
(begin (log-optimization
"unboxed function -> table"
fun-name)
#t)
(dict-set! unboxed-funs-table fun-name
(list (reverse unboxed)
(reverse boxed))))]
@ -105,6 +110,8 @@
(could-be-unboxed-in?
(car params) #'(begin body ...)))
;; we can unbox
(log-optimization "unboxed var -> table"
(car params))
(loop (cons i unboxed) boxed
(add1 i) (cdr params) (cdr doms))]
[else ; can't unbox
@ -278,6 +285,7 @@
(syntax->list #'(to-unbox ...)))
#:with res
(begin
(log-optimization "fun -> unboxed fun" #'v)
;; add unboxed parameters to the unboxed vars table
(let ((to-unbox (map syntax->datum (syntax->list #'(to-unbox ...)))))
(let loop ((params (syntax->list #'params))

6
collects/typed-scheme/optimizer/vector.rkt
View File

@ -30,7 +30,7 @@
(~literal unsafe-vector*-length)))
v:vector-expr)
#:with opt
(begin (log-optimization "known-length vector" #'op)
(begin (log-optimization "known-length vector-length" #'op)
(match (type-of #'v)
[(tc-result1: (HeterogenousVector: es))
#`(begin v.opt #,(length es))]))) ; v may have side effects
@ -39,12 +39,12 @@
;; we can optimize no matter what.
(pattern (#%plain-app (~and op (~literal vector-length)) v:expr)
#:with opt
(begin (log-optimization "vector" #'op)
(begin (log-optimization "vector-length" #'op)
#`(unsafe-vector*-length #,((optimize) #'v))))
;; same for flvector-length
(pattern (#%plain-app (~and op (~literal flvector-length)) v:expr)
#:with opt
(begin (log-optimization "flvector" #'op)
(begin (log-optimization "flvector-length" #'op)
#`(unsafe-flvector-length #,((optimize) #'v))))
;; we can optimize vector ref and set! on vectors of known length if we know
;; the index is within bounds (for now, literal or singleton type)