Use syntax-track-origin more pervasively to get the right arrows in check syntax.
original commit: d948626fac529ba8325ffe712f192edb4e5329d5
This commit is contained in:
Sam Tobin-Hochstadt
parent
bc5339d19c
commit
20c54979a9
|
|
@ -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))))))))))
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user