diff --git a/collects/typed-scheme/optimizer/apply.rkt b/collects/typed-scheme/optimizer/apply.rkt index 73dc5f2c..81925601 100644 --- a/collects/typed-scheme/optimizer/apply.rkt +++ b/collects/typed-scheme/optimizer/apply.rkt @@ -16,8 +16,8 @@ (define-syntax-class apply-opt-expr #:commit #:literals (k:apply map #%plain-app #%app) - (pattern (#%plain-app (~and app k:apply) op:apply-op - (#%plain-app (~and m map) f l)) + (pattern ((~and kw #%plain-app) (~and appl k:apply) op:apply-op + ((~and kw2 #%plain-app) (~and m map) f l)) #:with opt (begin (reset-unboxed-gensym) (with-syntax ([(f* lp v lst) (map unboxed-gensym '(f* loop v lst))] @@ -25,12 +25,14 @@ [f ((optimize) #'f)]) (log-optimization "apply-map" "apply-map deforestation." this-syntax) - (add-disappeared-use #'app) - (add-disappeared-use #'op) + (add-disappeared-use #'appl) + (add-disappeared-use #'kw2) (add-disappeared-use #'m) - #'(let ([f* f]) - (let lp ([v op.identity] [lst l]) - (if (null? lst) - v - (lp (op v (f* (unsafe-car lst))) - (unsafe-cdr lst))))))))) + (syntax/loc/origin + this-syntax #'kw + (let ([f* f]) + (let lp ([v op.identity] [lst l]) + (if (null? lst) + v + (lp (op v (f* (unsafe-car lst))) + (unsafe-cdr lst)))))))))) diff --git a/collects/typed-scheme/optimizer/dead-code.rkt b/collects/typed-scheme/optimizer/dead-code.rkt index eb944149..01fa25e8 100644 --- a/collects/typed-scheme/optimizer/dead-code.rkt +++ b/collects/typed-scheme/optimizer/dead-code.rkt @@ -12,19 +12,23 @@ #:commit ;; if one of the brances of an if is unreachable, we can eliminate it ;; we have to keep the test, in case it has side effects - (pattern (if tst:expr thn:expr els:expr) + (pattern ((~and kw (~literal if)) tst:expr thn:expr els:expr) #:when (tautology? #'tst) #:with opt (begin (log-optimization "dead else branch" "Unreachable else branch elimination." #'els) - #`(#%expression (begin #,((optimize) #'tst) - #,((optimize) #'thn))))) - (pattern (if tst:expr thn:expr els:expr) + (quasisyntax/loc/origin + this-syntax #'kw + (#%expression (begin #,((optimize) #'tst) + #,((optimize) #'thn)))))) + (pattern ((~and kw (~literal if)) tst:expr thn:expr els:expr) #:when (contradiction? #'tst) #:with opt (begin (log-optimization "dead then branch" "Unreachable then branch elimination." #'thn) - #`(#%expression (begin #,((optimize) #'tst) - #,((optimize) #'els)))))) + (quasisyntax/loc/origin + this-syntax #'kw + (#%expression (begin #,((optimize) #'tst) + #,((optimize) #'els))))))) diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt index 00eddd6b..594941e0 100644 --- a/collects/typed-scheme/optimizer/optimizer.rkt +++ b/collects/typed-scheme/optimizer/optimizer.rkt @@ -16,6 +16,7 @@ (pattern e:opt-expr* #:with opt #'e.opt)) + (define-syntax-class opt-expr* #:commit #:literal-sets (kernel-literals) @@ -39,10 +40,8 @@ ;; boring cases, just recur down (pattern ((~and op (~or (~literal #%plain-lambda) (~literal define-values))) formals e:expr ...) - #:with opt (syntax-track-origin (quasisyntax/loc this-syntax (op formals #,@(syntax-map (optimize) #'(e ...)))) - this-syntax - #'op)) - (pattern (case-lambda [formals e:expr ...] ...) + #:with opt (quasisyntax/loc/origin this-syntax #'op (op formals #,@(syntax-map (optimize) #'(e ...))))) + (pattern ((~and op case-lambda) [formals e:expr ...] ...) ;; optimize all the bodies #:with (opt-parts ...) (syntax-map (lambda (part) @@ -50,23 +49,23 @@ (cons (car l) (map (optimize) (cdr l))))) #'([formals e ...] ...)) - #:with opt (syntax/loc this-syntax (case-lambda opt-parts ...))) + #:with opt (syntax/loc/origin this-syntax #'op (case-lambda opt-parts ...))) (pattern ((~and op (~or (~literal let-values) (~literal letrec-values))) ([ids e-rhs:expr] ...) e-body:expr ...) #:with (opt-rhs ...) (syntax-map (optimize) #'(e-rhs ...)) - #:with opt (quasisyntax/loc this-syntax + #:with opt (quasisyntax/loc/origin this-syntax #'op (op ([ids opt-rhs] ...) #,@(syntax-map (optimize) #'(e-body ...))))) - (pattern (letrec-syntaxes+values stx-bindings - ([(ids ...) e-rhs:expr] ...) - e-body:expr ...) + (pattern ((~and op letrec-syntaxes+values) stx-bindings + ([(ids ...) e-rhs:expr] ...) + e-body:expr ...) ;; optimize all the rhss #:with (opt-clauses ...) (syntax-map (lambda (clause) (let ((l (syntax->list clause))) (list (car l) ((optimize) (cadr l))))) #'([(ids ...) e-rhs] ...)) - #:with opt (quasisyntax/loc this-syntax + #:with opt (quasisyntax/loc/origin this-syntax #'op (letrec-syntaxes+values stx-bindings (opt-clauses ...) @@ -77,7 +76,7 @@ #'#%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 opt (quasisyntax/loc this-syntax + #:with opt (quasisyntax/loc/origin this-syntax #'kw (kw #,@(syntax-map (optimize) #'(expr ...))))) (pattern other:expr #:with opt #'other)) diff --git a/collects/typed-scheme/optimizer/unboxed-let.rkt b/collects/typed-scheme/optimizer/unboxed-let.rkt index 584d3ca6..04cc6405 100644 --- a/collects/typed-scheme/optimizer/unboxed-let.rkt +++ b/collects/typed-scheme/optimizer/unboxed-let.rkt @@ -143,21 +143,23 @@ ;; in the case where no bindings are unboxed, we create a let ;; that is equivalent to the original, but with all parts ;; optimized - #`(letk.key ... + (quasisyntax/loc/origin this-syntax #'letk.kw + (letk.key ... (opt-candidates.bindings ... ... opt-functions.res ... opt-others.res ...) - #,@(syntax-map (optimize) #'(body ...)))))) + #,@(syntax-map (optimize) #'(body ...))))))) (define-splicing-syntax-class let-like-keyword #:commit #:literal-sets (kernel-literals) - (pattern (~literal let-values) - #:with (key ...) #'(let*-values)) - (pattern (~literal letrec-values) - #:with (key ...) #'(letrec-values)) - (pattern (~seq (~literal letrec-syntaxes+values) stx-bindings) - #:with (key ...) #'(letrec-syntaxes+values stx-bindings))) + #:attributes ([key 1] kw) + (pattern (~and kw (~literal let-values)) + #:with (key ...) #'(kw)) + (pattern (~and kw (~literal letrec-values)) + #:with (key ...) #'(kw)) + (pattern (~seq (~and kw (~literal letrec-syntaxes+values)) stx-bindings) + #:with (key ...) #'(kw stx-bindings))) (define (direct-child-of? v exp) diff --git a/collects/typed-scheme/optimizer/utils.rkt b/collects/typed-scheme/optimizer/utils.rkt index e2c94cae..c76b38bb 100644 --- a/collects/typed-scheme/optimizer/utils.rkt +++ b/collects/typed-scheme/optimizer/utils.rkt @@ -13,7 +13,14 @@ n-ary->binary unboxed-gensym reset-unboxed-gensym optimize - print-res) + print-res + syntax/loc/origin quasisyntax/loc/origin) + +;; for tracking both origin and source location information +(define-syntax-rule (syntax/loc/origin loc op body) + (syntax-track-origin (syntax/loc loc body) loc op)) +(define-syntax-rule (quasisyntax/loc/origin loc op body) + (syntax-track-origin (quasisyntax/loc loc body) loc op)) ;; if set to #t, the optimizer will dump its result to stdout before compilation (define *show-optimized-code* #f)