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

Have arity raising play nice with Check Syntax.

Browse Source 
original commit: becaac8c1841638350dec7e59f92efe37885aa7d
This commit is contained in:
Vincent St-Amour 2011-08-14 16:30:33 -04:00
parent 4ec5413e5f
commit a05162c6df
6 changed files with 34 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/typed-scheme/core.rkt
View File

@ -37,7 +37,11 @@
;; potentially optimize the code based on the type information
[(optimized-body ...) (maybe-optimize #'transformed-body)]
;; add in syntax property on useless expression to draw check-syntax arrows
[check-syntax-help (syntax-property #'(void) 'disappeared-use (disappeared-use-todo))])
[check-syntax-help (syntax-property
(syntax-property
#'(void)
'disappeared-binding (disappeared-bindings-todo))
'disappeared-use (disappeared-use-todo))])
;; reconstruct the module with the extra code
;; use the regular %#module-begin from `racket/base' for top-level printing
(arm #`(#%module-begin optimized-body ... #,after-code check-syntax-help))))))]))

20
collects/typed-scheme/optimizer/float-complex.rkt
View File

@ -15,7 +15,7 @@
;; contains the bindings which actually exist as separate bindings for each component
;; associates identifiers to lists (real-binding imag-binding)
;; associates identifiers to lists (real-binding imag-binding orig-binding-occurrence)
(define unboxed-vars-table (make-free-id-table))
;; associates the names of functions with unboxed args (and whose call sites have to
@ -312,12 +312,17 @@
(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 real-binding (car (syntax->list #'unboxed-info))
#:with imag-binding (cadr (syntax->list #'unboxed-info))
#:with orig-binding (caddr (syntax->list #'unboxed-info))
#:with (bindings ...)
(begin (log-optimization "leave var unboxed"
complex-unboxing-opt-msg
this-syntax)
;; we need to introduce both the binding and the use at the
;; same time
(add-disappeared-use (syntax-local-introduce #'v))
(add-disappeared-binding (syntax-local-introduce #'orig-binding))
#'()))
;; else, do the unboxing here
@ -524,14 +529,19 @@
#:with unboxed-info (dict-ref unboxed-vars-table #'v #f)
#:when (syntax->datum #'unboxed-info)
#:when (subtypeof? #'v -FloatComplex)
#:with real-binding (car (syntax->list #'unboxed-info))
#:with imag-binding (cadr (syntax->list #'unboxed-info))
#:with real-binding (car (syntax->list #'unboxed-info))
#:with imag-binding (cadr (syntax->list #'unboxed-info))
#:with orig-binding (caddr (syntax->list #'unboxed-info))
#:with (bindings ...) #'()
;; unboxed variable used in a boxed fashion, we have to box
#:with opt
(begin (log-optimization "unboxed complex variable"
complex-unboxing-opt-msg
this-syntax)
;; we need to introduce both the binding and the use at the
;; same time
(add-disappeared-use (syntax-local-introduce #'v))
(add-disappeared-binding (syntax-local-introduce #'orig-binding))
(reset-unboxed-gensym)
#'(unsafe-make-flrectangular real-binding imag-binding))))

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

@ -139,7 +139,7 @@
(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)))
(dict-set! unboxed-vars-table v (list r i v)))
;; in the case where no bindings are unboxed, we create a let
;; that is equivalent to the original, but with all parts
;; optimized
@ -321,7 +321,7 @@
[(memq i to-unbox) ; we unbox the current param, add to the table
(dict-set! unboxed-vars-table (car params)
(list (car real-parts) (car imag-parts)))
(list (car real-parts) (car imag-parts) (car params)))
(loop (cdr params) (add1 i)
(cdr real-parts) (cdr imag-parts)
boxed)]

9
collects/typed-scheme/private/with-types.rkt
View File

@ -83,7 +83,8 @@
(type-alias-env-map (lambda (id ty)
(cons (syntax-e id) ty)))))]
;; reinitialize disappeared uses
[disappeared-use-todo null]
[disappeared-use-todo null]
[disappeared-bindings-todo null]
;; for error reporting
[orig-module-stx stx]
[expanded-module-stx expanded-body])
@ -99,7 +100,11 @@
[(ex-cnt ...) ex-cnts]
[(region-cnt ...) region-cnts]
[body (maybe-optimize expanded-body)]
[check-syntax-help (syntax-property #'(void) 'disappeared-use (disappeared-use-todo))])
[check-syntax-help (syntax-property
(syntax-property
#'(void)
'disappeared-binding (disappeared-bindings-todo))
'disappeared-use (disappeared-use-todo))])
(if expr?
(quasisyntax/loc stx
(begin check-syntax-help

3
collects/typed-scheme/tc-setup.rkt
View File

@ -57,7 +57,8 @@
(type-alias-env-map (lambda (id ty)
(cons (syntax-e id) ty)))))]
;; reinitialize disappeared uses
[disappeared-use-todo null])
[disappeared-use-todo null]
[disappeared-bindings-todo null])
(do-time "Initialized Envs")
(let ([fully-expanded-stx (disarm* (local-expand stx expand-ctxt null))])
(when (show-input?)

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

@ -182,9 +182,11 @@ don't depend on any other portion of the system
;; list of syntax objects that should count as disappeared uses
(define disappeared-use-todo (make-parameter '()))
(define (add-disappeared-use t)
(disappeared-use-todo (cons t (disappeared-use-todo))))
(define disappeared-bindings-todo (make-parameter '()))
(define (add-disappeared-binding t)
(disappeared-bindings-todo (cons t (disappeared-bindings-todo))))
;; environment constructor
(define-syntax (make-env stx)