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

Fix to tolerate complexes of unknown exactness inside inexact-complex

Browse Source 
expressions.

original commit: 1b998f25e5626ff18bf18c911c4b161a66574b72
This commit is contained in:
Vincent St-Amour 2010-07-25 18:45:18 -04:00
commit 6473855e45
25 changed files with 570 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/tests/typed-scheme/optimizer/generic/apply-plus.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang typed/racket #:optimize
(require racket/unsafe/ops)
(apply + (map add1 (list 1 2 3)))
(apply * (map add1 (list 1 2 3)))

9
collects/tests/typed-scheme/optimizer/generic/box.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(: x (Boxof Integer))
(define x (box 1))
(unbox x)
(set-box! x 2)
(unbox x)

12
collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let.rkt Normal file
View File

@ -0,0 +1,12 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(let ((t1 (+ 1.0+2.0i 2.0+4.0i)) ; can be unboxed
(t2 (+ 3.0+6.0i 4.0+8.0i)) ; can't be unboxed
(t3 1.0+2.0i) ; can't be unboxed
(t4 1))
(display (+ t1 t1))
(display t2)
(display t3)
(display t4))

7
collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let2.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
;; unboxing of let bindings does not currently work with multiple values
(let-values (((t1 t2) (values (+ 1.0+2.0i 2.0+4.0i) (+ 3.0+6.0i 4.0+8.0i))))
(+ t1 t2))

6
collects/tests/typed-scheme/optimizer/generic/let-rhs.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(let ((x (+ 1.0 2.0)))
x)

20
collects/tests/typed-scheme/optimizer/generic/one-arg-arith.rkt Normal file
View File

@ -0,0 +1,20 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(- 12)
(- 12.0)
(/ 4.2)
(+ 1)
(+ 1.0)
(+ (expt 2 100))
(* 1)
(* 1.0)
(* (expt 2 100))
(min 1)
(min 1.0)
(min (expt 2 100))
(max 1)
(max 1.0)
(max (expt 2 100))

6
collects/tests/typed-scheme/optimizer/generic/string-length.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(string-length "eh")
(bytes-length #"eh")

8
collects/tests/typed-scheme/optimizer/generic/unboxed-let.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(let* ((t1 (+ 1.0+2.0i 2.0+4.0i))
(t2 (- t1 3.0+6.0i))
(t3 4.0+8.0i))
(+ t2 t3))

7
collects/tests/typed-scheme/optimizer/generic/unboxed-let2.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(let ((t1 (+ 1.0+2.0i 2.0+4.0i))
(t2 (+ 3.0+6.0i 4.0+8.0i)))
(+ t1 t2))

4
collects/tests/typed-scheme/optimizer/generic/zero.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(zero? 1)
(zero? (sqrt 3.0))

23
collects/tests/typed-scheme/run.rkt
View File

@ -4,30 +4,39 @@
(require "main.ss")
(define exec (make-parameter go/text))
(define the-tests (make-parameter tests))
(define skip-all? #f)
(define the-tests (make-parameter #f))
(define nightly? (make-parameter #f))
(define unit? (make-parameter #f))
(define int? (make-parameter #f))
(define opt? (make-parameter #f))
(define bench? (make-parameter #f))
(current-namespace (make-base-namespace))
(command-line
#:once-each
["--unit" "run just the unit tests" (the-tests unit-tests)]
["--int" "run just the integration tests" (the-tests int-tests)]
["--nightly" "for the nightly builds" (nightly? #t)]
["--unit" "run the unit tests" (unit? #t)]
["--int" "run the integration tests" (int? #t)]
["--nightly" "for the nightly builds" (begin (nightly? #t) (unit? #t) (int? #t))]
["--just" path "run only this test" (the-tests (just-one path))]
["--opt" "run the optimizer tests" (opt? #t)]
["--benchmarks" "compile the typed benchmarks" (bench? #t)]
["--all" "run all tests" (begin (unit? #t) (int? #t) (opt? #t) (bench? #t))]
["--gui" "run using the gui"
(if (gui-available?)
(begin (exec go))
(error "GUI not available"))]
)
(the-tests
(cond [(and (unit?) (int?)) tests]
[(unit?) unit-tests]
[(int?) int-tests]
[else #f]))
(cond [(and (nightly?) (eq? 'cgc (system-type 'gc)))
(printf "Skipping Typed Racket tests.\n")]
[(unless (= 0 ((exec) (the-tests)))
(eprintf "Typed Racket Tests did not pass."))
[(when (the-tests)
(unless (= 0 ((exec) (the-tests)))
(eprintf "Typed Racket Tests did not pass.")))
(when (opt?)
(parameterize ([current-command-line-arguments #()])
(dynamic-require '(file "optimizer/run.rkt") #f))

32
collects/typed-scheme/optimizer/apply.rkt Normal file
View File

@ -0,0 +1,32 @@
#lang scheme/base
(require syntax/parse
syntax/id-table racket/dict
unstable/match scheme/match
(for-template scheme/unsafe/ops racket/base (prefix-in k: '#%kernel))
(for-syntax racket/base)
"../utils/utils.rkt"
(rep type-rep)
(types abbrev type-table utils subtype)
(optimizer utils))
(provide apply-opt-expr)
(define-syntax-class apply-op
#:literals (+ *)
(pattern + #:with identity #'0)
(pattern * #:with identity #'1))
(define-syntax-class apply-opt-expr
#:literals (k:apply map #%plain-app #%app)
(pattern (#%plain-app k:apply op:apply-op (#%plain-app map f l))
#:with opt
(begin (reset-unboxed-gensym)
(with-syntax ([(f* lp v lst) (map unboxed-gensym '(f* loop v lst))]
[l ((optimize) #'l)]
[f ((optimize) #'f)])
(log-optimization "apply-map" #'op)
#'(let ([f* f])
(let lp ([v op.identity] [lst l])
(if (null? lst)
v
(lp (op v (f* (unsafe-car lst))) (unsafe-cdr lst)))))))))

29
collects/typed-scheme/optimizer/box.rkt Normal file
View File

@ -0,0 +1,29 @@
#lang scheme/base
(require syntax/parse
unstable/match scheme/match
"../utils/utils.rkt"
(for-template scheme/base scheme/fixnum scheme/unsafe/ops)
(rep type-rep)
(types abbrev type-table utils subtype)
(optimizer utils))
(provide box-opt-expr)
(define-syntax-class box-expr
(pattern e:expr
#:when (match (type-of #'e)
[(tc-result1: (Box: _)) #t]
[_ #f])
#:with opt ((optimize) #'e)))
(define-syntax-class box-op
;; we need the * versions of these unsafe operations to be chaperone-safe
(pattern (~literal unbox) #:with unsafe #'unsafe-unbox*)
(pattern (~literal set-box!) #:with unsafe #'unsafe-set-box*!))
(define-syntax-class box-opt-expr
(pattern (#%plain-app op:box-op b:box-expr new:expr ...)
#:with opt
(begin (log-optimization "box" #'op)
#`(op.unsafe b.opt #,@(map (optimize) (syntax->list #'(new ...)))))))

13
collects/typed-scheme/optimizer/fixnum.rkt
View File

@ -71,7 +71,18 @@
#:with opt
(begin (log-optimization "binary nonzero fixnum" #'op)
#'(op.unsafe n1.opt n2.opt)))
(pattern (#%plain-app (~and op (~literal -)) f:fixnum-expr)
#:with opt
(begin (log-optimization "unary fixnum" #'op)
#'(unsafe-fx- 0 f.opt)))
(pattern (#%plain-app (~and op (~literal exact->inexact)) n:fixnum-expr)
#:with opt
(begin (log-optimization "fixnum to float" #'op)
#'(unsafe-fx->fl n.opt))))
#'(unsafe-fx->fl n.opt)))
(pattern (#%plain-app (~and op (~literal zero?)) n:fixnum-expr)
#:with opt
(begin (log-optimization "fixnum zero?" #'op)
#'(unsafe-fx= n.opt 0))))

24
collects/typed-scheme/optimizer/float.rkt
View File

@ -68,13 +68,22 @@
#:with opt
(begin (log-optimization "binary float" #'op)
(n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...))))
(pattern (~and res (#%plain-app (~var op (float-op binary-float-comps))
f1:float-expr
f2:float-expr
fs:float-expr ...))
(pattern (#%plain-app (~var op (float-op binary-float-comps))
f1:float-expr
f2:float-expr
fs:float-expr ...)
#:with opt
(begin (log-optimization "binary float comp" #'op)
(n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...))))
(pattern (#%plain-app (~and op (~literal -)) f:float-expr)
#:with opt
(begin (log-optimization "unary float" #'op)
#'(unsafe-fl- 0.0 f.opt)))
(pattern (#%plain-app (~and op (~literal /)) f:float-expr)
#:with opt
(begin (log-optimization "unary float" #'op)
#'(unsafe-fl/ 1.0 f.opt)))
;; we can optimize exact->inexact if we know we're giving it an Integer
(pattern (#%plain-app (~and op (~literal exact->inexact)) n:int-expr)
@ -85,4 +94,9 @@
(pattern (#%plain-app (~and op (~literal exact->inexact)) f:float-expr)
#:with opt
(begin (log-optimization "float to float" #'op)
#'f.opt)))
#'f.opt))
(pattern (#%plain-app (~and op (~literal zero?)) f:float-expr)
#:with opt
(begin (log-optimization "float zero?" #'op)
#'(unsafe-fl= f.opt 0.0))))

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

@ -1,90 +1,101 @@
#lang scheme/base
(require syntax/parse
(require syntax/parse syntax/id-table scheme/dict
"../utils/utils.rkt"
(for-template scheme/base scheme/math scheme/flonum scheme/unsafe/ops)
(types abbrev type-table utils subtype)
(optimizer utils float fixnum))
(provide inexact-complex-opt-expr)
(provide inexact-complex-opt-expr inexact-complex-arith-opt-expr
unboxed-inexact-complex-opt-expr unboxed-vars-table)
;; contains the bindings which actually exist as separate bindings for each component
;; associates identifiers to lists (real-binding imag-binding)
(define unboxed-vars-table (make-free-id-table))
;; it's faster to take apart a complex number and use unsafe operations on
;; its parts than it is to use generic operations
;; we keep the real and imaginary parts unboxed as long as we stay within
;; complex operations
(define-syntax-class unboxed-inexact-complex-opt-expr
(pattern (#%plain-app (~and op (~literal +))
c1:unboxed-inexact-complex-opt-expr
c2:unboxed-inexact-complex-opt-expr
cs:unboxed-inexact-complex-opt-expr ...)
#:with real-part (unboxed-gensym)
#:with imag-part (unboxed-gensym)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with (bindings ...)
(begin (log-optimization "unboxed binary inexact complex" #'op)
#`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...))
(list #`(real-part #,(for/fold ((o #'c1.real-part))
((e (syntax->list #'(c2.real-part cs.real-part ...))))
#`(unsafe-fl+ #,o #,e)))
;; we can skip the imaginary parts of reals (#f)
#`(imag-part
#,(let ((l (filter syntax->datum
(syntax->list #'(c1.imag-part c2.imag-part cs.imag-part ...)))))
(case (length l)
((0) #'0.0)
((1) (car l))
(else
(for/fold ((o (car l)))
((e (cdr l)))
#`(unsafe-fl+ #,o #,e)))))))))))
(let ()
;; we can skip the real parts of imaginaries (#f) and vice versa
(define (skip-0s l)
(let ((l (filter syntax->datum (syntax->list l))))
(case (length l)
((0) #'0.0)
((1) (car l))
(else
(for/fold ((o (car l)))
((e (cdr l)))
#`(unsafe-fl+ #,o #,e))))))
(list
#`(real-binding #,(skip-0s #'(c1.real-binding c2.real-binding cs.real-binding ...)))
#`(imag-binding #,(skip-0s #'(c1.imag-binding c2.imag-binding cs.imag-binding ...)))))))))
(pattern (#%plain-app (~and op (~literal -))
c1:unboxed-inexact-complex-opt-expr
c2:unboxed-inexact-complex-opt-expr
cs:unboxed-inexact-complex-opt-expr ...)
#:with real-part (unboxed-gensym)
#:with imag-part (unboxed-gensym)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with (bindings ...)
(begin (log-optimization "unboxed binary inexact complex" #'op)
#`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...))
(list #`(real-part #,(for/fold ((o #'c1.real-part))
((e (syntax->list #'(c2.real-part cs.real-part ...))))
#`(unsafe-fl- #,o #,e)))
;; unlike addition, we simply can't skip imaginary parts of reals
#`(imag-part
#,(let* ((l1 (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.imag-part c2.imag-part cs.imag-part ...))))
;; but we can skip all but the first 0
(l2 (filter (lambda (x) (not (equal? (syntax->datum x) 0.0)))
(cdr l1))))
(case (length l2)
((0) (car l1))
(else
(for/fold ((o (car l1)))
((e l2))
#`(unsafe-fl- #,o #,e)))))))))))
(let ()
;; unlike addition, we simply can't skip real parts of imaginaries
(define (skip-0s l)
(let* ((l1 (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list l)))
;; but we can skip all but the first 0
(l2 (filter (lambda (x) (not (equal? (syntax->datum x) 0.0)))
(cdr l1))))
(case (length l2)
((0) (car l1))
(else
(for/fold ((o (car l1)))
((e l2))
#`(unsafe-fl- #,o #,e))))))
(list
#`(real-binding #,(skip-0s #'(c1.real-binding c2.real-binding cs.real-binding ...)))
#`(imag-binding #,(skip-0s #'(c1.imag-binding c2.imag-binding cs.imag-binding ...)))))))))
(pattern (#%plain-app (~and op (~literal *))
c1:unboxed-inexact-complex-opt-expr
c2:unboxed-inexact-complex-opt-expr
cs:unboxed-inexact-complex-opt-expr ...)
#:with real-part (unboxed-gensym)
#:with imag-part (unboxed-gensym)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with (bindings ...)
(begin (log-optimization "unboxed binary inexact complex" #'op)
#`(c1.bindings ... c2.bindings ... cs.bindings ... ...
;; we want to bind the intermediate results to reuse them
;; the final results are bound to real-part and imag-part
#,@(let ((l (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.imag-part c2.imag-part cs.imag-part ...)))))
(let loop ([o1 #'c1.real-part]
[o2 (car l)]
[e1 (syntax->list #'(c2.real-part cs.real-part ...))]
[e2 (cdr l)]
;; the final results are bound to real-binding and imag-binding
#,@(let ((lr (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.real-binding c2.real-binding cs.real-binding ...))))
(li (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.imag-binding c2.imag-binding cs.imag-binding ...)))))
(let loop ([o1 (car lr)]
[o2 (car li)]
[e1 (cdr lr)]
[e2 (cdr li)]
[rs (append (map (lambda (x) (unboxed-gensym))
(syntax->list #'(cs.real-part ...)))
(list #'real-part))]
(syntax->list #'(cs.real-binding ...)))
(list #'real-binding))]
[is (append (map (lambda (x) (unboxed-gensym))
(syntax->list #'(cs.imag-part ...)))
(list #'imag-part))]
(syntax->list #'(cs.imag-binding ...)))
(list #'imag-binding))]
[res '()])
(if (null? e1)
(reverse res)
@ -107,32 +118,34 @@
#`(unsafe-fl- (unsafe-fl* #,o1 #,(car e1))
(unsafe-fl* #,o2 #,(car e2))))))
res)))))))))
(pattern (#%plain-app (~and op (~literal /))
c1:unboxed-inexact-complex-opt-expr
c2:unboxed-inexact-complex-opt-expr
cs:unboxed-inexact-complex-opt-expr ...)
#:with real-part (unboxed-gensym)
#:with imag-part (unboxed-gensym)
#:with reals (syntax->list #'(c1.real-part c2.real-part cs.real-part ...))
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with reals (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.real-binding c2.real-binding cs.real-binding ...)))
#:with imags (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.imag-part c2.imag-part cs.imag-part ...)))
(syntax->list #'(c1.imag-binding c2.imag-binding cs.imag-binding ...)))
#:with (bindings ...)
(begin (log-optimization "unboxed binary inexact complex" #'op)
#`(c1.bindings ... c2.bindings ... cs.bindings ... ...
;; we want to bind the intermediate results to reuse them
;; the final results are bound to real-part and imag-part
;; the final results are bound to real-binding and imag-binding
#,@(let loop ([o1 (car (syntax->list #'reals))]
[o2 (car (syntax->list #'imags))]
[e1 (cdr (syntax->list #'reals))]
[e2 (cdr (syntax->list #'imags))]
[rs (append (map (lambda (x) (unboxed-gensym))
(syntax->list #'(cs.real-part ...)))
(list #'real-part))]
(syntax->list #'(cs.real-binding ...)))
(list #'real-binding))]
[is (append (map (lambda (x) (unboxed-gensym))
(syntax->list #'(cs.imag-part ...)))
(list #'imag-part))]
(syntax->list #'(cs.imag-binding ...)))
(list #'imag-binding))]
[ds (map (lambda (x) (unboxed-gensym))
(syntax->list #'(c2.real-part cs.real-part ...)))]
(syntax->list #'(c2.real-binding cs.real-binding ...)))]
[res '()])
(if (null? e1)
(reverse res)
@ -175,55 +188,88 @@
(unsafe-fl+ (unsafe-fl* #,(car e1) #,(car e1))
(unsafe-fl* #,(car e2) #,(car e2))))
res)]))))))))
(pattern (#%plain-app (~and op (~literal conjugate)) c:unboxed-inexact-complex-opt-expr)
#:with real-part #'c.real-part
#:with imag-part (unboxed-gensym)
#:with real-binding #'c.real-binding
#:with imag-binding (unboxed-gensym)
#:with (bindings ...)
(begin (log-optimization "unboxed unary inexact complex" #'op)
#`(#,@(append (syntax->list #'(c.bindings ...))
(list #'(imag-part (unsafe-fl- 0.0 c.imag-part)))))))
(list #'(imag-binding (unsafe-fl- 0.0 c.imag-binding)))))))
(pattern (#%plain-app (~and op (~or (~literal real-part) (~literal unsafe-flreal-part)))
c:unboxed-inexact-complex-opt-expr)
#:with real-binding #'c.real-binding
#:with imag-binding #f
#:with (bindings ...)
(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)
#:with real-binding #'c.imag-binding
#:with imag-binding #f
#:with (bindings ...)
(begin (log-optimization "unboxed unary inexact complex" #'op)
#'(c.bindings ...)))
;; if we see a variable that's already unboxed, use the unboxed bindings
(pattern v:id
#:with unboxed-info (dict-ref unboxed-vars-table #'v #f)
#:when (syntax->datum #'unboxed-info)
#:with real-binding (car (syntax->list #'unboxed-info))
#:with imag-binding (cadr (syntax->list #'unboxed-info))
#:with (bindings ...) #'())
;; else, do the unboxing here
(pattern e:expr
#:when (isoftype? #'e -InexactComplex)
#:with e* (unboxed-gensym)
#:with real-part (unboxed-gensym)
#:with imag-part (unboxed-gensym)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with (bindings ...)
#`((e* #,((optimize) #'e))
(real-part (unsafe-flreal-part e*))
(imag-part (unsafe-flimag-part e*))))
(real-binding (unsafe-flreal-part e*))
(imag-binding (unsafe-flimag-part e*))))
;; special handling of reals
(pattern e:float-expr
#:with real-part (unboxed-gensym)
#:with imag-part #f
#:with real-binding (unboxed-gensym)
#:with imag-binding #f
#:with (bindings ...)
#`((real-part #,((optimize) #'e))))
#`((real-binding #,((optimize) #'e))))
(pattern e:fixnum-expr
#:with real-part (unboxed-gensym)
#:with imag-part #f
#:with real-binding (unboxed-gensym)
#:with imag-binding #f
#:with (bindings ...)
#`((real-part (unsafe-fx->fl #,((optimize) #'e)))))
#`((real-binding (unsafe-fx->fl #,((optimize) #'e)))))
(pattern e:int-expr
#:with real-part (unboxed-gensym)
#:with imag-part #f
#:with real-binding (unboxed-gensym)
#:with imag-binding #f
#:with (bindings ...)
#`((real-part (->fl #,((optimize) #'e)))))
#`((real-binding (->fl #,((optimize) #'e)))))
(pattern e:expr
#:when (isoftype? #'e -Real)
#:with real-part (unboxed-gensym)
#:with imag-part #f
#:with real-binding (unboxed-gensym)
#:with imag-binding #f
#:with (bindings ...)
#`((real-part (exact->inexact #,((optimize) #'e)))))
#`((real-binding (exact->inexact #,((optimize) #'e)))))
(pattern e:expr
#:when (isoftype? #'e -Number) ; complex, maybe exact, maybe not
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with (bindings ...)
#`((real-binding (real-part #,((optimize) #'e)))
(imag-binding (imag-part #,((optimize) #'e)))))
(pattern e:expr
#:with (bindings ...)
(error "non exhaustive pattern match")
#:with real-part #f
#:with imag-part #f))
#:with real-binding #f
#:with imag-binding #f))
(define-syntax-class inexact-complex-unary-op
(pattern (~or (~literal real-part) (~literal flreal-part)) #:with unsafe #'unsafe-flreal-part)
(pattern (~or (~literal imag-part) (~literal flimag-part)) #:with unsafe #'unsafe-flimag-part))
(define-syntax-class inexact-complex-binary-op
(define-syntax-class inexact-complex-op
(pattern (~or (~literal +) (~literal -) (~literal *) (~literal /) (~literal conjugate))))
(define-syntax-class inexact-complex-expr
@ -232,15 +278,39 @@
#:with opt ((optimize) #'e)))
(define-syntax-class inexact-complex-opt-expr
;; we can optimize taking the real of imag part of an unboxed complex
;; hopefully, the compiler can eliminate unused bindings for the other part if it's not used
(pattern (#%plain-app (~and op (~or (~literal real-part) (~literal unsafe-flreal-part)
(~literal imag-part) (~literal unsafe-flimag-part)))
c:inexact-complex-expr)
#:with c*:inexact-complex-arith-opt-expr #'c
#:with opt
(begin (log-optimization "unboxed inexact complex" #'op)
(reset-unboxed-gensym)
#`(let* (c*.bindings ...)
#,(if (or (free-identifier=? #'op #'real-part)
(free-identifier=? #'op #'unsafe-flreal-part))
#'c*.real-binding
#'c*.imag-binding))))
(pattern (#%plain-app op:inexact-complex-unary-op n:inexact-complex-expr)
#:with opt
(begin (log-optimization "unary inexact complex" #'op)
#'(op.unsafe n.opt)))
(pattern (~and exp (#%plain-app op:inexact-complex-binary-op e:expr ...))
(pattern e:inexact-complex-arith-opt-expr
#:with opt
#'e.opt))
(define-syntax-class inexact-complex-arith-opt-expr
(pattern (~and exp (#%plain-app op:inexact-complex-op e:expr ...))
#:when (isoftype? #'exp -InexactComplex)
#:with exp*:unboxed-inexact-complex-opt-expr #'exp
#:with real-binding #'exp*.real-binding
#:with imag-binding #'exp*.imag-binding
#:with (bindings ...) #'(exp*.bindings ...)
#:with opt
(begin (log-optimization "unboxed inexact complex" #'exp)
(reset-unboxed-gensym)
#'(let* (exp*.bindings ...)
(unsafe-make-flrectangular exp*.real-part exp*.imag-part)))))
(unsafe-make-flrectangular exp*.real-binding exp*.imag-binding)))))

16
collects/typed-scheme/optimizer/number.rkt Normal file
View File

@ -0,0 +1,16 @@
#lang scheme/base
(require syntax/parse
(for-template scheme/base scheme/flonum scheme/unsafe/ops)
"../utils/utils.rkt"
(optimizer utils))
(provide number-opt-expr)
(define-syntax-class number-opt-expr
;; these cases are all identity
(pattern (#%plain-app (~and op (~or (~literal +) (~literal *) (~literal min) (~literal max)))
f:expr)
#:with opt
(begin (log-optimization "unary number" #'op)
((optimize) #'f))))

82
collects/typed-scheme/optimizer/optimizer.rkt
View File

@ -2,10 +2,13 @@
(require syntax/parse
syntax/id-table racket/dict
(for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops racket/private/for)
(for-template scheme/base
scheme/flonum scheme/fixnum scheme/unsafe/ops
racket/private/for)
"../utils/utils.rkt"
(types abbrev type-table utils subtype)
(optimizer utils fixnum float inexact-complex vector pair sequence struct dead-code))
(optimizer utils number fixnum float inexact-complex vector string
pair sequence box struct dead-code apply unboxed-let))
(provide optimize-top)
@ -18,35 +21,58 @@
#:literal-sets (kernel-literals)
;; interesting cases, where something is optimized
(pattern e:apply-opt-expr #:with opt #'e.opt)
(pattern e:number-opt-expr #:with opt #'e.opt)
(pattern e:fixnum-opt-expr #:with opt #'e.opt)
(pattern e:float-opt-expr #:with opt #'e.opt)
(pattern e:inexact-complex-opt-expr #:with opt #'e.opt)
(pattern e:vector-opt-expr #:with opt #'e.opt)
(pattern e:string-opt-expr #:with opt #'e.opt)
(pattern e:pair-opt-expr #:with opt #'e.opt)
(pattern e:sequence-opt-expr #:with opt #'e.opt)
(pattern e:box-opt-expr #:with opt #'e.opt)
(pattern e:struct-opt-expr #:with opt #'e.opt)
(pattern e:dead-code-opt-expr #:with opt #'e.opt)
(pattern e:unboxed-let-opt-expr #:with opt #'e.opt)
;; boring cases, just recur down
(pattern (#%plain-lambda formals e:opt-expr ...)
#:with opt #'(#%plain-lambda formals e.opt ...))
(pattern (define-values formals e:opt-expr ...)
#:with opt #'(define-values formals e.opt ...))
(pattern (case-lambda [formals e:opt-expr ...] ...)
#:with opt #'(case-lambda [formals e.opt ...] ...))
(pattern (let-values ([ids e-rhs:opt-expr] ...) e-body:opt-expr ...)
#:with opt #'(let-values ([ids e-rhs.opt] ...) e-body.opt ...))
(pattern (letrec-values ([ids e-rhs:opt-expr] ...) e-body:opt-expr ...)
#:with opt #'(letrec-values ([ids e-rhs.opt] ...) e-body.opt ...))
(pattern (letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs:opt-expr] ...) e-body:opt-expr ...)
#:with opt #'(letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs.opt] ...) e-body.opt ...))
(pattern ((~and op (~or (~literal #%plain-lambda) (~literal define-values)))
formals e:expr ...)
#:with opt #`(op formals #,@(map (optimize) (syntax->list #'(e ...)))))
(pattern (case-lambda [formals e:expr ...] ...)
;; optimize all the bodies
#:with (opt-parts ...)
(map (lambda (part)
(let ((l (syntax->list part)))
(cons (car l)
(map (optimize) (cdr l)))))
(syntax->list #'([formals e ...] ...)))
#:with opt #'(case-lambda opt-parts ...))
(pattern ((~and op (~or (~literal let-values) (~literal letrec-values)))
([ids e-rhs:expr] ...) e-body:expr ...)
#:with (opt-rhs ...) (map (optimize) (syntax->list #'(e-rhs ...)))
#:with opt #`(op ([ids opt-rhs] ...)
#,@(map (optimize) (syntax->list #'(e-body ...)))))
(pattern (letrec-syntaxes+values stx-bindings
([(ids ...) e-rhs:expr] ...)
e-body:expr ...)
;; optimize all the rhss
#:with (opt-clauses ...)
(map (lambda (clause)
(let ((l (syntax->list clause)))
(list (car l) ((optimize) (cadr l)))))
(syntax->list #'([(ids ...) e-rhs] ...)))
#:with opt #`(letrec-syntaxes+values
stx-bindings
(opt-clauses ...)
#,@(map (optimize) (syntax->list #'(e-body ...)))))
(pattern (kw:identifier expr ...)
#:when (ormap (lambda (k) (free-identifier=? k #'kw))
(list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
#'#%variable-reference #'with-continuation-mark))
#:when
(for/or ([k (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
#'#%variable-reference #'with-continuation-mark)])
(free-identifier=? k #'kw))
;; we don't want to optimize in the cases that don't match the #:when clause
#:with (expr*:opt-expr ...) #'(expr ...)
#:with opt #'(kw expr*.opt ...))
#:with opt #`(kw #,@(map (optimize) (syntax->list #'(expr ...)))))
(pattern other:expr
#:with opt #'other))
@ -58,12 +84,14 @@
(current-output-port))))
(begin0
(parameterize ([current-output-port port]
[optimize (lambda (stx)
(syntax-parse stx #:literal-sets (kernel-literals)
[e:opt-expr
(syntax/loc stx e.opt)]))])
[optimize (syntax-parser
[e:expr
#:when (and (not (syntax-property #'e 'typechecker:ignore))
(not (syntax-property #'e 'typechecker:with-handlers)))
#:with e*:opt-expr #'e
#'e*.opt]
[e:expr #'e])])
((optimize) stx))
(if (and *log-optimizations?*
*log-optimizatons-to-log-file?*)
(close-output-port port)
#t))))
(when (and *log-optimizations?*
*log-optimizatons-to-log-file?*)
(close-output-port port)))))

11
collects/typed-scheme/optimizer/sequence.rkt
View File

@ -7,7 +7,7 @@
"../utils/utils.rkt" "../utils/tc-utils.rkt"
(rep type-rep)
(types abbrev type-table utils subtype)
(optimizer utils))
(optimizer utils string))
(provide sequence-opt-expr)
@ -29,15 +29,6 @@
[_ #f])
#:with opt ((optimize) #'e)))
(define-syntax-class string-expr
(pattern e:expr
#:when (isoftype? #'e -String)
#:with opt ((optimize) #'e)))
(define-syntax-class bytes-expr
(pattern e:expr
#:when (isoftype? #'e -Bytes)
#:with opt ((optimize) #'e)))
(define-syntax-class sequence-opt-expr
;; if we're iterating (with the for macros) over something we know is a list,
;; we can generate code that would be similar to if in-list had been used

28
collects/typed-scheme/optimizer/string.rkt Normal file
View File

@ -0,0 +1,28 @@
#lang scheme/base
(require syntax/parse
(for-template scheme/base scheme/flonum scheme/unsafe/ops)
"../utils/utils.rkt"
(types abbrev type-table utils subtype)
(optimizer utils))
(provide string-opt-expr string-expr bytes-expr)
(define-syntax-class string-expr
(pattern e:expr
#:when (isoftype? #'e -String)
#:with opt ((optimize) #'e)))
(define-syntax-class bytes-expr
(pattern e:expr
#:when (isoftype? #'e -Bytes)
#:with opt ((optimize) #'e)))
(define-syntax-class string-opt-expr
(pattern (#%plain-app (~literal string-length) s:string-expr)
#:with opt
(begin (log-optimization "string" #'op)
#'(unsafe-string-length s.opt)))
(pattern (#%plain-app (~literal bytes-length) s:bytes-expr)
#:with opt
(begin (log-optimization "bytes" #'op)
#'(unsafe-bytes-length s.opt))))

100
collects/typed-scheme/optimizer/unboxed-let.rkt Normal file
View File

@ -0,0 +1,100 @@
#lang scheme/base
(require syntax/parse
scheme/list scheme/dict
"../utils/utils.rkt"
"../utils/tc-utils.rkt"
(for-template scheme/base)
(types abbrev)
(optimizer utils inexact-complex))
(provide unboxed-let-opt-expr)
;; possibly replace bindings of complex numbers by bindings of their 2 components
;; useful for intermediate results used more than once and for loop variables
(define-syntax-class unboxed-let-opt-expr
#:literal-sets (kernel-literals)
(pattern (~and exp (let-values (clause:expr ...) body:expr ...))
;; we look for bindings of complexes that are not mutated and only
;; used in positions where we would unbox them
;; these are candidates for unboxing
#:with ((candidates ...) (others ...))
(let-values
(((candidates others)
;; clauses of form ((v) rhs), currently only supports 1 lhs var
(partition (lambda (p)
(and (isoftype? (cadr p) -InexactComplex)
(let ((v (car (syntax-e (car p)))))
(not (is-var-mutated? v))
(could-be-unboxed-in? v #'(begin body ...)))))
(map syntax->list (syntax->list #'(clause ...))))))
(list candidates others))
#:with (opt-candidates:unboxed-let-clause ...) #'(candidates ...)
#:with (opt-others:let-clause ...) #'(others ...)
#:with opt
(begin (log-optimization "unboxed let bindings" #'exp)
;; add the unboxed bindings to the table, for them to be used by
;; further optimizations
(for ((v (in-list (syntax->list #'(opt-candidates.id ...))))
(r (in-list (syntax->list #'(opt-candidates.real-binding ...))))
(i (in-list (syntax->list #'(opt-candidates.imag-binding ...)))))
(dict-set! unboxed-vars-table v (list r i)))
#`(let* (opt-candidates.bindings ... ... opt-others.res ...)
#,@(map (optimize) (syntax->list #'(body ...)))))))
;; if a variable is only used in complex arithmetic operations, it's safe
;; to unbox it
(define (could-be-unboxed-in? v exp)
(define (direct-child-of? exp)
(ormap (lambda (x) (and (identifier? x) (free-identifier=? x v)))
(syntax->list exp)))
;; if v is a direct child of exp, that means it's used in a boxed
;; fashion, and is not safe to unboxed
;; if not, recur on the subforms
(define (look-at exp)
(and (not (direct-child-of? exp))
(andmap rec (syntax->list exp))))
(define (rec exp)
(syntax-parse exp
#:literal-sets (kernel-literals)
;; can be used in a complex arithmetic expr, can be a direct child
[exp:inexact-complex-arith-opt-expr
(andmap rec (syntax->list #'exp))]
;; recur down
[((~and op (~or (~literal #%plain-lambda) (~literal define-values)))
formals e:expr ...)
(look-at #'(e ...))]
[(case-lambda [formals e:expr ...] ...)
(look-at #'(e ... ...))]
[((~or (~literal let-values) (~literal letrec-values))
([ids e-rhs:expr] ...) e-body:expr ...)
(look-at #'(e-rhs ... e-body ...))]
[(letrec-syntaxes+values stx-bindings
([(ids ...) e-rhs:expr] ...)
e-body:expr ...)
(look-at #'(e-rhs ... e-body ...))]
[(kw:identifier expr ...)
#:when (ormap (lambda (k) (free-identifier=? k #'kw))
(list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
#'#%variable-reference #'with-continuation-mark))
(look-at #'(expr ...))]
;; not used, safe to unbox
[_ #t]))
(rec exp))
(define-syntax-class unboxed-let-clause
(pattern ((v:id) rhs:unboxed-inexact-complex-opt-expr)
#:with id #'v
#:with real-binding #'rhs.real-binding
#:with imag-binding #'rhs.imag-binding
#:with (bindings ...) #'(rhs.bindings ...)))
(define-syntax-class let-clause ; to turn let-values clauses into let clauses
(pattern ((v:id) rhs:expr)
#:with res #`(v #,((optimize) #'rhs))))

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

@ -52,9 +52,9 @@
;; necessary to have predictable symbols to add in the hand-optimized versions
;; of the optimizer tests (which check for equality of expanded code)
(define *unboxed-gensym-counter* 0)
(define (unboxed-gensym)
(define (unboxed-gensym [name 'unboxed-gensym-])
(set! *unboxed-gensym-counter* (add1 *unboxed-gensym-counter*))
(format-unique-id #'here "unboxed-gensym-~a" *unboxed-gensym-counter*))
(format-unique-id #'here "~a~a" name *unboxed-gensym-counter*))
(define (reset-unboxed-gensym)
(set! *unboxed-gensym-counter* 0))

28
collects/typed-scheme/private/base-env-numeric.rkt
View File

@ -235,27 +235,24 @@
[* (apply cl->*
(append (for/list ([t (list -Pos -Nat -Integer -ExactRational -NonnegativeFlonum -Flonum)]) (->* (list) t t))
(list (->* (list -Pos) -NonnegativeFlonum -NonnegativeFlonum))
(list (->* (list -NonnegativeFlonum) -Pos -NonnegativeFlonum))
(list (->* (list -Pos) -Flonum -Flonum))
(list (->* (list -Flonum) -Pos -Flonum))
(list (->* (list) (Un -Pos -NonnegativeFlonum) -NonnegativeFlonum))
(list (->* (list) (Un -Pos -Flonum) -Flonum))
(list (->* (list) -Real -Real))
(list (->* (list) -InexactComplex -InexactComplex))
(list (->* (list) (Un -InexactComplex -Flonum) -InexactComplex))
(list (->* (list) N N))))]
[+ (apply cl->*
(append (list (->* (list -Pos) -Nat -Pos))
(list (->* (list -Nat) -Pos -Pos))
(list (->* (list -Nat -Pos) -Nat -Pos))
(for/list ([t (list -Nat -Integer -ExactRational -NonnegativeFlonum -Flonum)]) (->* (list) t t))
(list (->* (list -Nat) -NonnegativeFlonum -NonnegativeFlonum))
(list (->* (list -NonnegativeFlonum) -Nat -NonnegativeFlonum))
;; special cases for promotion to inexact, not exhaustive
;; valid for + and -, but not for * and /, since (* <float> 0) is exact 0 (i.e. not a float)
(list (->* (list) (Un -Nat -NonnegativeFlonum) -NonnegativeFlonum))
(list (->* (list -Flonum) -Real -Flonum))
(list (->* (list -Real -Flonum) -Real -Flonum))
(list (->* (list) -Real -Real))
(list (->* (list -Real) -InexactComplex -InexactComplex))
(list (->* (list -InexactComplex) -Real -InexactComplex))
(list (->* (list) -InexactComplex -InexactComplex))
(list (->* (list) (Un -Real -InexactComplex) -InexactComplex))
(list (->* (list -InexactComplex) N -InexactComplex))
(list (->* (list N -InexactComplex) N -InexactComplex))
(list (->* (list) N N))))]
[- (apply cl->*
@ -264,9 +261,9 @@
(list (->* (list -Flonum) -Real -Flonum))
(list (->* (list -Real -Flonum) -Real -Flonum))
(list (->* (list -Real) -Real -Real))
(list (->* (list -Real) -InexactComplex -InexactComplex))
(list (->* (list -InexactComplex) -Real -InexactComplex))
(list (->* (list -InexactComplex) -InexactComplex -InexactComplex))
(list (->* (list) (Un -Real -InexactComplex) -InexactComplex))
(list (->* (list -InexactComplex) N -InexactComplex))
(list (->* (list N -InexactComplex) N -InexactComplex))
(list (->* (list N) N N))))]
[/ (apply cl->*
(append (list (->* (list -Integer) -Integer -ExactRational))
@ -275,6 +272,7 @@
;; only exact 0 as first argument can cause the result of a division involving inexacts to be exact
(list (->* (list -Flonum) -Real -Flonum))
(list (->* (list -Real) -Real -Real))
(list (->* (list (Un -Flonum -InexactComplex)) (Un -Real -InexactComplex) -InexactComplex))
(list (->* (list -InexactComplex) -InexactComplex -InexactComplex))
(list (->* (list N) N N))))]
@ -340,7 +338,9 @@
(-Nat -Nat . -> . -Nat)
(-Integer -Integer . -> . -Integer))]
[bitwise-and (cl->* (null -NonnegativeFixnum . ->* . -NonnegativeFixnum)
((list -Integer) -NonnegativeFixnum . ->* . -NonnegativeFixnum)
(null -Fixnum . ->* . -Fixnum)
((list -Integer) -Fixnum . ->* . -Fixnum)
(null -Nat . ->* . -Nat)
(null -Integer . ->* . -Integer))]
[bitwise-ior (cl->* (null -NonnegativeFixnum . ->* . -NonnegativeFixnum)

10
collects/typed-scheme/private/base-env.rkt
View File

@ -200,10 +200,18 @@
[newline (->opt [-Output-Port] -Void)]
[not (-> Univ B)]
[box (-poly (a) (a . -> . (-box a)))]
[unbox (-poly (a) (cl->*
[unbox (-poly (a) (cl->*
((-box a) . -> . a)
((make-BoxTop) . -> . Univ)))]
[set-box! (-poly (a) ((-box a) a . -> . -Void))]
[unsafe-unbox (-poly (a) (cl->*
((-box a) . -> . a)
((make-BoxTop) . -> . Univ)))]
[unsafe-set-box! (-poly (a) ((-box a) a . -> . -Void))]
[unsafe-unbox* (-poly (a) (cl->*
((-box a) . -> . a)
((make-BoxTop) . -> . Univ)))]
[unsafe-set-box*! (-poly (a) ((-box a) a . -> . -Void))]
[box? (make-pred-ty (make-BoxTop))]
[cons? (make-pred-ty (-pair Univ Univ))]
[pair? (make-pred-ty (-pair Univ Univ))]

2
collects/typed-scheme/types/abbrev.rkt
View File

@ -176,7 +176,7 @@
(define -ExactNonnegativeInteger (*Un -ExactPositiveInteger -Zero))
(define -Nat -ExactNonnegativeInteger)
(define -Byte -Integer)
(define -Byte -NonnegativeFixnum)