Optimize in typed regions.
This commit is contained in:
parent
c8999c2541
commit
e057e6a857
16
collects/tests/typed-scheme/optimizer/tests/with-type.rkt
Normal file
16
collects/tests/typed-scheme/optimizer/tests/with-type.rkt
Normal file
|
@ -0,0 +1,16 @@
|
||||||
|
#;
|
||||||
|
(
|
||||||
|
with-type.rkt line 13 col 19 - + - binary float
|
||||||
|
34.6
|
||||||
|
)
|
||||||
|
|
||||||
|
#lang racket
|
||||||
|
|
||||||
|
(require typed/racket)
|
||||||
|
|
||||||
|
(with-type ([fun (Float -> Float)]
|
||||||
|
[val Float])
|
||||||
|
(define (fun x) (+ x val))
|
||||||
|
(define val 17.3))
|
||||||
|
|
||||||
|
(fun val)
|
|
@ -6,7 +6,6 @@
|
||||||
(private with-types type-contract)
|
(private with-types type-contract)
|
||||||
(except-in syntax/parse id)
|
(except-in syntax/parse id)
|
||||||
racket/match racket/syntax unstable/match
|
racket/match racket/syntax unstable/match
|
||||||
(optimizer optimizer)
|
|
||||||
(types utils convenience)
|
(types utils convenience)
|
||||||
(typecheck typechecker provide-handling tc-toplevel)
|
(typecheck typechecker provide-handling tc-toplevel)
|
||||||
(env type-name-env type-alias-env)
|
(env type-name-env type-alias-env)
|
||||||
|
@ -18,13 +17,6 @@
|
||||||
|
|
||||||
(provide mb-core ti-core wt-core)
|
(provide mb-core ti-core wt-core)
|
||||||
|
|
||||||
(define (maybe-optimize body)
|
|
||||||
;; do we optimize?
|
|
||||||
(if (optimize?)
|
|
||||||
(begin0 (map optimize-top (syntax->list body))
|
|
||||||
(do-time "Optimized"))
|
|
||||||
body))
|
|
||||||
|
|
||||||
(define (mb-core stx)
|
(define (mb-core stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(mb (~optional (~or (~and #:optimize (~bind [opt? #'#t])) ; kept for backward compatibility
|
[(mb (~optional (~or (~and #:optimize (~bind [opt? #'#t])) ; kept for backward compatibility
|
||||||
|
|
|
@ -6,6 +6,7 @@
|
||||||
"../base-env/prims.rkt"
|
"../base-env/prims.rkt"
|
||||||
(prefix-in c: (combine-in racket/contract/region racket/contract/base)))
|
(prefix-in c: (combine-in racket/contract/region racket/contract/base)))
|
||||||
"../base-env/extra-procs.rkt" "../base-env/prims.rkt"
|
"../base-env/extra-procs.rkt" "../base-env/prims.rkt"
|
||||||
|
"../tc-setup.rkt"
|
||||||
syntax/parse racket/block racket/match
|
syntax/parse racket/block racket/match
|
||||||
unstable/sequence "../base-env/base-types-extra.rkt"
|
unstable/sequence "../base-env/base-types-extra.rkt"
|
||||||
(except-in (path-up "env/type-name-env.rkt"
|
(except-in (path-up "env/type-name-env.rkt"
|
||||||
|
@ -97,7 +98,7 @@
|
||||||
[(ex-id ...) exids]
|
[(ex-id ...) exids]
|
||||||
[(ex-cnt ...) ex-cnts]
|
[(ex-cnt ...) ex-cnts]
|
||||||
[(region-cnt ...) region-cnts]
|
[(region-cnt ...) region-cnts]
|
||||||
[body expanded-body]
|
[body (maybe-optimize expanded-body)]
|
||||||
[check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))])
|
[check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))])
|
||||||
(if expr?
|
(if expr?
|
||||||
(quasisyntax/loc stx
|
(quasisyntax/loc stx
|
||||||
|
|
|
@ -5,6 +5,7 @@
|
||||||
unstable/mutated-vars
|
unstable/mutated-vars
|
||||||
racket/pretty
|
racket/pretty
|
||||||
scheme/base
|
scheme/base
|
||||||
|
(optimizer optimizer)
|
||||||
(private type-contract)
|
(private type-contract)
|
||||||
(types utils convenience)
|
(types utils convenience)
|
||||||
(typecheck typechecker provide-handling tc-toplevel)
|
(typecheck typechecker provide-handling tc-toplevel)
|
||||||
|
@ -18,12 +19,19 @@
|
||||||
(for-syntax racket/base)
|
(for-syntax racket/base)
|
||||||
(for-template racket/base))
|
(for-template racket/base))
|
||||||
|
|
||||||
(provide tc-setup invis-kw)
|
(provide tc-setup invis-kw maybe-optimize)
|
||||||
|
|
||||||
(define-syntax-class invis-kw
|
(define-syntax-class invis-kw
|
||||||
#:literals (define-values define-syntaxes #%require #%provide begin)
|
#:literals (define-values define-syntaxes #%require #%provide begin)
|
||||||
(pattern (~or define-values define-syntaxes #%require #%provide begin)))
|
(pattern (~or define-values define-syntaxes #%require #%provide begin)))
|
||||||
|
|
||||||
|
(define (maybe-optimize body)
|
||||||
|
;; do we optimize?
|
||||||
|
(if (optimize?)
|
||||||
|
(begin0 (map optimize-top (syntax->list body))
|
||||||
|
(do-time "Optimized"))
|
||||||
|
body))
|
||||||
|
|
||||||
(define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx checker result . body)
|
(define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx checker result . body)
|
||||||
(let ()
|
(let ()
|
||||||
(set-box! typed-context? #t)
|
(set-box! typed-context? #t)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user