diff --git a/collects/typed-scheme/core.rkt b/collects/typed-scheme/core.rkt index 658ddde1..6113e7a3 100644 --- a/collects/typed-scheme/core.rkt +++ b/collects/typed-scheme/core.rkt @@ -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))))))])) diff --git a/collects/typed-scheme/optimizer/float-complex.rkt b/collects/typed-scheme/optimizer/float-complex.rkt index 67a5532e..283943ee 100644 --- a/collects/typed-scheme/optimizer/float-complex.rkt +++ b/collects/typed-scheme/optimizer/float-complex.rkt @@ -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)))) diff --git a/collects/typed-scheme/optimizer/unboxed-let.rkt b/collects/typed-scheme/optimizer/unboxed-let.rkt index 4034924f..09facc48 100644 --- a/collects/typed-scheme/optimizer/unboxed-let.rkt +++ b/collects/typed-scheme/optimizer/unboxed-let.rkt @@ -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)] diff --git a/collects/typed-scheme/private/with-types.rkt b/collects/typed-scheme/private/with-types.rkt index 02ffbf19..835e01b7 100644 --- a/collects/typed-scheme/private/with-types.rkt +++ b/collects/typed-scheme/private/with-types.rkt @@ -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 diff --git a/collects/typed-scheme/tc-setup.rkt b/collects/typed-scheme/tc-setup.rkt index 90d55df2..e8dd1060 100644 --- a/collects/typed-scheme/tc-setup.rkt +++ b/collects/typed-scheme/tc-setup.rkt @@ -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?) diff --git a/collects/typed-scheme/utils/tc-utils.rkt b/collects/typed-scheme/utils/tc-utils.rkt index e3afbb06..5a7291e6 100644 --- a/collects/typed-scheme/utils/tc-utils.rkt +++ b/collects/typed-scheme/utils/tc-utils.rkt @@ -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)