Move from syntax-map to stx-map.
This commit is contained in:
parent
4af6b6ffcf
commit
3e4a8acf70
|
@ -1,6 +1,6 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(require syntax/parse unstable/syntax
|
(require syntax/parse syntax/stx
|
||||||
racket/match
|
racket/match
|
||||||
"../utils/utils.rkt"
|
"../utils/utils.rkt"
|
||||||
(for-template racket/base racket/unsafe/ops)
|
(for-template racket/base racket/unsafe/ops)
|
||||||
|
@ -31,4 +31,4 @@
|
||||||
#:with opt
|
#:with opt
|
||||||
(begin (log-optimization "box" "Box check elimination." this-syntax)
|
(begin (log-optimization "box" "Box check elimination." this-syntax)
|
||||||
(add-disappeared-use #'op)
|
(add-disappeared-use #'op)
|
||||||
#`(op.unsafe b.opt #,@(syntax-map (optimize) #'(new ...))))))
|
#`(op.unsafe b.opt #,@(stx-map (optimize) #'(new ...))))))
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(require syntax/parse syntax/id-table racket/dict unstable/syntax racket/match
|
(require syntax/parse syntax/stx syntax/id-table racket/dict
|
||||||
|
unstable/syntax racket/match
|
||||||
"../utils/utils.rkt" racket/unsafe/ops unstable/sequence
|
"../utils/utils.rkt" racket/unsafe/ops unstable/sequence
|
||||||
(for-template racket/base racket/math racket/flonum racket/unsafe/ops)
|
(for-template racket/base racket/math racket/flonum racket/unsafe/ops)
|
||||||
(utils tc-utils)
|
(utils tc-utils)
|
||||||
|
@ -127,7 +128,7 @@
|
||||||
(let ()
|
(let ()
|
||||||
;; unlike addition, we simply can't skip real parts of imaginaries
|
;; unlike addition, we simply can't skip real parts of imaginaries
|
||||||
(define (skip-0s l)
|
(define (skip-0s l)
|
||||||
(let* ((l1 (syntax-map get-part-or-0.0 l))
|
(let* ((l1 (stx-map get-part-or-0.0 l))
|
||||||
;; but we can skip all but the first 0
|
;; but we can skip all but the first 0
|
||||||
(l2 (filter (lambda (x) (not (equal? (syntax->datum x) 0.0)))
|
(l2 (filter (lambda (x) (not (equal? (syntax->datum x) 0.0)))
|
||||||
(cdr l1))))
|
(cdr l1))))
|
||||||
|
@ -168,18 +169,18 @@
|
||||||
#`(c1.bindings ... c2.bindings ... cs.bindings ... ...
|
#`(c1.bindings ... c2.bindings ... cs.bindings ... ...
|
||||||
;; we want to bind the intermediate results to reuse them
|
;; we want to bind the intermediate results to reuse them
|
||||||
;; the final results are bound to real-binding and imag-binding
|
;; the final results are bound to real-binding and imag-binding
|
||||||
#,@(let ((lr (syntax-map get-part-or-0.0
|
#,@(let ((lr (stx-map get-part-or-0.0
|
||||||
#'(c1.real-binding c2.real-binding cs.real-binding ...)))
|
#'(c1.real-binding c2.real-binding cs.real-binding ...)))
|
||||||
(li (syntax-map get-part-or-0.0
|
(li (stx-map get-part-or-0.0
|
||||||
#'(c1.imag-binding c2.imag-binding cs.imag-binding ...))))
|
#'(c1.imag-binding c2.imag-binding cs.imag-binding ...))))
|
||||||
(let loop ([o1 (car lr)]
|
(let loop ([o1 (car lr)]
|
||||||
[o2 (car li)]
|
[o2 (car li)]
|
||||||
[e1 (cdr lr)]
|
[e1 (cdr lr)]
|
||||||
[e2 (cdr li)]
|
[e2 (cdr li)]
|
||||||
[rs (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
|
[rs (append (stx-map (lambda (x) (unboxed-gensym "unboxed-real-"))
|
||||||
#'(cs.real-binding ...))
|
#'(cs.real-binding ...))
|
||||||
(list #'real-binding))]
|
(list #'real-binding))]
|
||||||
[is (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
|
[is (append (stx-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
|
||||||
#'(cs.imag-binding ...))
|
#'(cs.imag-binding ...))
|
||||||
(list #'imag-binding))]
|
(list #'imag-binding))]
|
||||||
[res '()])
|
[res '()])
|
||||||
|
@ -212,9 +213,9 @@
|
||||||
#:when (subtypeof? this-syntax -FloatComplex)
|
#:when (subtypeof? this-syntax -FloatComplex)
|
||||||
#:with real-binding (unboxed-gensym "unboxed-real-")
|
#:with real-binding (unboxed-gensym "unboxed-real-")
|
||||||
#:with imag-binding (unboxed-gensym "unboxed-imag-")
|
#:with imag-binding (unboxed-gensym "unboxed-imag-")
|
||||||
#:with reals (syntax-map get-part-or-0.0
|
#:with reals (stx-map get-part-or-0.0
|
||||||
#'(c1.real-binding c2.real-binding cs.real-binding ...))
|
#'(c1.real-binding c2.real-binding cs.real-binding ...))
|
||||||
#:with imags (syntax-map get-part-or-0.0
|
#:with imags (stx-map get-part-or-0.0
|
||||||
#'(c1.imag-binding c2.imag-binding cs.imag-binding ...))
|
#'(c1.imag-binding c2.imag-binding cs.imag-binding ...))
|
||||||
#:with (bindings ...)
|
#:with (bindings ...)
|
||||||
(begin (log-optimization "unboxed binary float complex"
|
(begin (log-optimization "unboxed binary float complex"
|
||||||
|
@ -228,10 +229,10 @@
|
||||||
[b (car (syntax->list #'imags))]
|
[b (car (syntax->list #'imags))]
|
||||||
[e1 (cdr (syntax->list #'reals))]
|
[e1 (cdr (syntax->list #'reals))]
|
||||||
[e2 (cdr (syntax->list #'imags))]
|
[e2 (cdr (syntax->list #'imags))]
|
||||||
[rs (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
|
[rs (append (stx-map (lambda (x) (unboxed-gensym "unboxed-real-"))
|
||||||
#'(cs.real-binding ...))
|
#'(cs.real-binding ...))
|
||||||
(list #'real-binding))]
|
(list #'real-binding))]
|
||||||
[is (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
|
[is (append (stx-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
|
||||||
#'(cs.imag-binding ...))
|
#'(cs.imag-binding ...))
|
||||||
(list #'imag-binding))]
|
(list #'imag-binding))]
|
||||||
[res '()])
|
[res '()])
|
||||||
|
@ -674,7 +675,7 @@
|
||||||
(reset-unboxed-gensym)
|
(reset-unboxed-gensym)
|
||||||
#`(let*-values (e.bindings ... ...)
|
#`(let*-values (e.bindings ... ...)
|
||||||
(#%plain-app #,opt-operator
|
(#%plain-app #,opt-operator
|
||||||
#,@(syntax-map get-part-or-0.0 #'(e.real-binding ...))
|
#,@(stx-map get-part-or-0.0 #'(e.real-binding ...))
|
||||||
#,@(syntax-map get-part-or-0.0 #'(e.imag-binding ...))
|
#,@(stx-map get-part-or-0.0 #'(e.imag-binding ...))
|
||||||
#,@(map (lambda (i) ((optimize) (get-arg i)))
|
#,@(map (lambda (i) ((optimize) (get-arg i)))
|
||||||
boxed)))])))) ; boxed params
|
boxed)))])))) ; boxed params
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(require syntax/parse unstable/syntax
|
(require syntax/parse syntax/stx
|
||||||
(for-template racket/base)
|
(for-template racket/base)
|
||||||
"../utils/utils.rkt"
|
"../utils/utils.rkt"
|
||||||
(optimizer utils logging)
|
(optimizer utils logging)
|
||||||
|
@ -31,11 +31,11 @@
|
||||||
(syntax->list #'(args ...)))
|
(syntax->list #'(args ...)))
|
||||||
#:with opt
|
#:with opt
|
||||||
(begin (log-optimization-info "hidden parameter" #'op)
|
(begin (log-optimization-info "hidden parameter" #'op)
|
||||||
#`(op #,@(syntax-map (optimize) #'(args ...)))))
|
#`(op #,@(stx-map (optimize) #'(args ...)))))
|
||||||
;; Log calls to struct constructors, so that OC can report those used in
|
;; Log calls to struct constructors, so that OC can report those used in
|
||||||
;; hot loops.
|
;; hot loops.
|
||||||
(pattern (#%plain-app op:id args ...)
|
(pattern (#%plain-app op:id args ...)
|
||||||
#:when (struct-constructor? #'op)
|
#:when (struct-constructor? #'op)
|
||||||
#:with opt
|
#:with opt
|
||||||
(begin (log-optimization-info "struct constructor" #'op)
|
(begin (log-optimization-info "struct constructor" #'op)
|
||||||
#`(op #,@(syntax-map (optimize) #'(args ...))))))
|
#`(op #,@(stx-map (optimize) #'(args ...))))))
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(require syntax/parse unstable/syntax
|
(require syntax/parse syntax/stx unstable/sequence
|
||||||
racket/pretty
|
racket/pretty
|
||||||
(for-template racket/base)
|
(for-template racket/base)
|
||||||
"../utils/utils.rkt"
|
"../utils/utils.rkt"
|
||||||
|
@ -51,36 +51,34 @@
|
||||||
;; boring cases, just recur down
|
;; boring cases, just recur down
|
||||||
(pattern ((~and op (~or (~literal #%plain-lambda) (~literal define-values)))
|
(pattern ((~and op (~or (~literal #%plain-lambda) (~literal define-values)))
|
||||||
formals e:expr ...)
|
formals e:expr ...)
|
||||||
#:with opt (quasisyntax/loc/origin this-syntax #'op (op formals #,@(syntax-map (optimize) #'(e ...)))))
|
#:with opt (quasisyntax/loc/origin this-syntax #'op (op formals #,@(stx-map (optimize) #'(e ...)))))
|
||||||
(pattern ((~and op case-lambda) [formals e:expr ...] ...)
|
(pattern ((~and op case-lambda) [formals e:expr ...] ...)
|
||||||
;; optimize all the bodies
|
;; optimize all the bodies
|
||||||
#:with (opt-parts ...)
|
#:with (opt-parts ...)
|
||||||
(syntax-map (lambda (part)
|
(for/list ([part (in-syntax #'([formals e ...] ...))])
|
||||||
(let ((l (syntax->list part)))
|
(let ((l (syntax->list part)))
|
||||||
(cons (car l)
|
(cons (car l)
|
||||||
(map (optimize) (cdr l)))))
|
(map (optimize) (cdr l)))))
|
||||||
#'([formals e ...] ...))
|
|
||||||
#:with opt (syntax/loc/origin this-syntax #'op (op opt-parts ...)))
|
#:with opt (syntax/loc/origin this-syntax #'op (op opt-parts ...)))
|
||||||
(pattern ((~and op (~or (~literal let-values) (~literal letrec-values)))
|
(pattern ((~and op (~or (~literal let-values) (~literal letrec-values)))
|
||||||
([ids e-rhs:expr] ...) e-body:expr ...)
|
([ids e-rhs:expr] ...) e-body:expr ...)
|
||||||
#:with (opt-rhs ...) (syntax-map (optimize) #'(e-rhs ...))
|
#:with (opt-rhs ...) (stx-map (optimize) #'(e-rhs ...))
|
||||||
#:with opt (quasisyntax/loc/origin this-syntax #'op
|
#:with opt (quasisyntax/loc/origin this-syntax #'op
|
||||||
(op ([ids opt-rhs] ...)
|
(op ([ids opt-rhs] ...)
|
||||||
#,@(syntax-map (optimize) #'(e-body ...)))))
|
#,@(stx-map (optimize) #'(e-body ...)))))
|
||||||
(pattern ((~and op letrec-syntaxes+values) stx-bindings
|
(pattern ((~and op letrec-syntaxes+values) stx-bindings
|
||||||
([(ids ...) e-rhs:expr] ...)
|
([(ids ...) e-rhs:expr] ...)
|
||||||
e-body:expr ...)
|
e-body:expr ...)
|
||||||
;; optimize all the rhss
|
;; optimize all the rhss
|
||||||
#:with (opt-clauses ...)
|
#:with (opt-clauses ...)
|
||||||
(syntax-map (lambda (clause)
|
(for/list ([clause (in-syntax #'([(ids ...) e-rhs] ...))])
|
||||||
(let ((l (syntax->list clause)))
|
(let ((l (syntax->list clause)))
|
||||||
(list (car l) ((optimize) (cadr l)))))
|
(list (car l) ((optimize) (cadr l)))))
|
||||||
#'([(ids ...) e-rhs] ...))
|
|
||||||
#:with opt (quasisyntax/loc/origin this-syntax #'op
|
#:with opt (quasisyntax/loc/origin this-syntax #'op
|
||||||
(letrec-syntaxes+values
|
(letrec-syntaxes+values
|
||||||
stx-bindings
|
stx-bindings
|
||||||
(opt-clauses ...)
|
(opt-clauses ...)
|
||||||
#,@(syntax-map (optimize) #'(e-body ...)))))
|
#,@(stx-map (optimize) #'(e-body ...)))))
|
||||||
(pattern (kw:identifier expr ...)
|
(pattern (kw:identifier expr ...)
|
||||||
#:when
|
#:when
|
||||||
(for/or ([k (in-list (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
|
(for/or ([k (in-list (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
|
||||||
|
@ -88,7 +86,7 @@
|
||||||
(free-identifier=? k #'kw))
|
(free-identifier=? k #'kw))
|
||||||
;; we don't want to optimize in the cases that don't match the #:when clause
|
;; we don't want to optimize in the cases that don't match the #:when clause
|
||||||
#:with opt (quasisyntax/loc/origin this-syntax #'kw
|
#:with opt (quasisyntax/loc/origin this-syntax #'kw
|
||||||
(kw #,@(syntax-map (optimize) #'(expr ...)))))
|
(kw #,@(stx-map (optimize) #'(expr ...)))))
|
||||||
(pattern other:expr
|
(pattern other:expr
|
||||||
#:with opt #'other))
|
#:with opt #'other))
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(require syntax/parse unstable/syntax
|
(require syntax/parse syntax/stx
|
||||||
racket/match
|
racket/match
|
||||||
(for-template racket/base racket/unsafe/ops racket/list)
|
(for-template racket/base racket/unsafe/ops racket/list)
|
||||||
"../utils/utils.rkt"
|
"../utils/utils.rkt"
|
||||||
|
@ -66,7 +66,7 @@
|
||||||
#:with opt
|
#:with opt
|
||||||
(begin (log-pair-opt this-syntax)
|
(begin (log-pair-opt this-syntax)
|
||||||
(add-disappeared-use #'op)
|
(add-disappeared-use #'op)
|
||||||
#`(op.unsafe #,@(syntax-map (optimize) #'(p e ...))))))
|
#`(op.unsafe #,@(stx-map (optimize) #'(p e ...))))))
|
||||||
|
|
||||||
|
|
||||||
;; change the source location of a given syntax object
|
;; change the source location of a given syntax object
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(require syntax/parse unstable/syntax
|
(require syntax/parse syntax/stx unstable/syntax
|
||||||
(for-template racket/base racket/unsafe/ops)
|
(for-template racket/base racket/unsafe/ops)
|
||||||
"../utils/utils.rkt"
|
"../utils/utils.rkt"
|
||||||
(utils tc-utils)
|
(utils tc-utils)
|
||||||
|
@ -25,4 +25,4 @@
|
||||||
#`(unsafe-struct-ref #,((optimize) #'s) #,idx))
|
#`(unsafe-struct-ref #,((optimize) #'s) #,idx))
|
||||||
(begin (log-optimization "struct set" struct-opt-msg this-syntax)
|
(begin (log-optimization "struct set" struct-opt-msg this-syntax)
|
||||||
#`(unsafe-struct-set! #,((optimize) #'s) #,idx
|
#`(unsafe-struct-set! #,((optimize) #'s) #,idx
|
||||||
#,@(syntax-map (optimize) #'(v ...))))))))
|
#,@(stx-map (optimize) #'(v ...))))))))
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(require syntax/parse unstable/syntax unstable/sequence
|
(require syntax/parse syntax/stx unstable/syntax unstable/sequence
|
||||||
racket/list racket/dict racket/match
|
racket/list racket/dict racket/match
|
||||||
"../utils/utils.rkt"
|
"../utils/utils.rkt"
|
||||||
"../utils/tc-utils.rkt"
|
"../utils/tc-utils.rkt"
|
||||||
|
@ -66,7 +66,7 @@
|
||||||
(and (subtypeof? (cadr p) -FloatComplex)
|
(and (subtypeof? (cadr p) -FloatComplex)
|
||||||
(could-be-unboxed-in? (car (syntax-e (car p)))
|
(could-be-unboxed-in? (car (syntax-e (car p)))
|
||||||
#'(begin body ...))))
|
#'(begin body ...))))
|
||||||
(syntax-map syntax->list #'(clause ...))))
|
(stx-map syntax->list #'(clause ...))))
|
||||||
((function-candidates others)
|
((function-candidates others)
|
||||||
;; extract function bindings that have float-complex arguments
|
;; extract function bindings that have float-complex arguments
|
||||||
;; we may be able to pass arguments unboxed
|
;; we may be able to pass arguments unboxed
|
||||||
|
@ -148,7 +148,7 @@
|
||||||
(opt-functions.res ...
|
(opt-functions.res ...
|
||||||
opt-others.res ...
|
opt-others.res ...
|
||||||
opt-candidates.bindings ... ...)
|
opt-candidates.bindings ... ...)
|
||||||
#,@(syntax-map (optimize) #'(body ...)))))))
|
#,@(stx-map (optimize) #'(body ...)))))))
|
||||||
|
|
||||||
(define-splicing-syntax-class let-like-keyword
|
(define-splicing-syntax-class let-like-keyword
|
||||||
#:commit
|
#:commit
|
||||||
|
@ -194,7 +194,7 @@
|
||||||
([ids e-rhs:expr] ...) e-body:expr ...)
|
([ids e-rhs:expr] ...) e-body:expr ...)
|
||||||
#:with rebindings
|
#:with rebindings
|
||||||
(filter (lambda (x) x)
|
(filter (lambda (x) x)
|
||||||
(syntax-map (syntax-parser
|
(stx-map (syntax-parser
|
||||||
[((id) rhs)
|
[((id) rhs)
|
||||||
#:when (and (identifier? #'rhs)
|
#:when (and (identifier? #'rhs)
|
||||||
(free-identifier=? v #'rhs))
|
(free-identifier=? v #'rhs))
|
||||||
|
@ -301,16 +301,14 @@
|
||||||
;; partition of the arguments
|
;; partition of the arguments
|
||||||
#:with ((to-unbox ...) (boxed ...)) #'unboxed-info
|
#:with ((to-unbox ...) (boxed ...)) #'unboxed-info
|
||||||
#:with (real-params ...)
|
#:with (real-params ...)
|
||||||
(syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
|
(stx-map (lambda (x) (unboxed-gensym "unboxed-real-")) #'(to-unbox ...))
|
||||||
#'(to-unbox ...))
|
|
||||||
#:with (imag-params ...)
|
#:with (imag-params ...)
|
||||||
(syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
|
(stx-map (lambda (x) (unboxed-gensym "unboxed-imag-")) #'(to-unbox ...))
|
||||||
#'(to-unbox ...))
|
|
||||||
#:with res
|
#:with res
|
||||||
(begin
|
(begin
|
||||||
(log-optimization "fun -> unboxed fun" arity-raising-opt-msg #'v)
|
(log-optimization "fun -> unboxed fun" arity-raising-opt-msg #'v)
|
||||||
;; add unboxed parameters to the unboxed vars table
|
;; add unboxed parameters to the unboxed vars table
|
||||||
(let ((to-unbox (syntax-map syntax->datum #'(to-unbox ...))))
|
(let ((to-unbox (syntax->datum #'(to-unbox ...))))
|
||||||
(let loop ((params (syntax->list #'params))
|
(let loop ((params (syntax->list #'params))
|
||||||
(i 0)
|
(i 0)
|
||||||
(real-parts (syntax->list #'(real-params ...)))
|
(real-parts (syntax->list #'(real-params ...)))
|
||||||
|
@ -323,7 +321,7 @@
|
||||||
#`((v) (#%plain-lambda
|
#`((v) (#%plain-lambda
|
||||||
(real-params ... imag-params ...
|
(real-params ... imag-params ...
|
||||||
#,@(reverse boxed))
|
#,@(reverse boxed))
|
||||||
#,@(syntax-map (optimize) #'(body ...))))]
|
#,@(stx-map (optimize) #'(body ...))))]
|
||||||
|
|
||||||
[(memq i to-unbox)
|
[(memq i to-unbox)
|
||||||
;; we unbox the current param, add to the table
|
;; we unbox the current param, add to the table
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(require syntax/parse unstable/syntax
|
(require syntax/parse syntax/stx
|
||||||
racket/match racket/flonum
|
racket/match racket/flonum
|
||||||
(for-template racket/base racket/flonum racket/unsafe/ops)
|
(for-template racket/base racket/flonum racket/unsafe/ops)
|
||||||
"../utils/utils.rkt"
|
"../utils/utils.rkt"
|
||||||
|
@ -74,7 +74,7 @@
|
||||||
(begin (log-optimization "vector" "Vector bounds checking elimination." this-syntax)
|
(begin (log-optimization "vector" "Vector bounds checking elimination." this-syntax)
|
||||||
(add-disappeared-use #'op)
|
(add-disappeared-use #'op)
|
||||||
#`(op.unsafe v.opt #,((optimize) #'i)
|
#`(op.unsafe v.opt #,((optimize) #'i)
|
||||||
#,@(syntax-map (optimize) #'(new ...)))))
|
#,@(stx-map (optimize) #'(new ...)))))
|
||||||
|
|
||||||
;; we can do the bounds checking separately, to eliminate some of the checks
|
;; we can do the bounds checking separately, to eliminate some of the checks
|
||||||
(pattern (#%plain-app op:vector-op v:expr i:fixnum-expr new:expr ...)
|
(pattern (#%plain-app op:vector-op v:expr i:fixnum-expr new:expr ...)
|
||||||
|
@ -83,7 +83,7 @@
|
||||||
"Partial bounds checking elimination."
|
"Partial bounds checking elimination."
|
||||||
this-syntax)
|
this-syntax)
|
||||||
(add-disappeared-use #'op)
|
(add-disappeared-use #'op)
|
||||||
(let ([safe-fallback #`(op new-v new-i #,@(syntax-map (optimize) #'(new ...)))]
|
(let ([safe-fallback #`(op new-v new-i #,@(stx-map (optimize) #'(new ...)))]
|
||||||
[i-known-nonneg? (subtypeof? #'i -NonNegFixnum)])
|
[i-known-nonneg? (subtypeof? #'i -NonNegFixnum)])
|
||||||
#`(let ([new-i #,((optimize) #'i)]
|
#`(let ([new-i #,((optimize) #'i)]
|
||||||
[new-v #,((optimize) #'v)])
|
[new-v #,((optimize) #'v)])
|
||||||
|
@ -95,7 +95,7 @@
|
||||||
one-sided
|
one-sided
|
||||||
#`(and (unsafe-fx>= new-i 0)
|
#`(and (unsafe-fx>= new-i 0)
|
||||||
#,one-sided)))
|
#,one-sided)))
|
||||||
(op.unsafe new-v new-i #,@(syntax-map (optimize) #'(new ...)))
|
(op.unsafe new-v new-i #,@(stx-map (optimize) #'(new ...)))
|
||||||
#,safe-fallback) ; will error. to give the right error message
|
#,safe-fallback) ; will error. to give the right error message
|
||||||
;; not an impersonator, can use unsafe-vector* ops
|
;; not an impersonator, can use unsafe-vector* ops
|
||||||
(if #,(let ([one-sided #'(unsafe-fx< new-i (unsafe-vector-length new-v))])
|
(if #,(let ([one-sided #'(unsafe-fx< new-i (unsafe-vector-length new-v))])
|
||||||
|
@ -103,7 +103,7 @@
|
||||||
one-sided
|
one-sided
|
||||||
#`(and (unsafe-fx>= new-i 0)
|
#`(and (unsafe-fx>= new-i 0)
|
||||||
#,one-sided)))
|
#,one-sided)))
|
||||||
(op.unsafe-no-impersonator new-v new-i #,@(syntax-map (optimize) #'(new ...)))
|
(op.unsafe-no-impersonator new-v new-i #,@(stx-map (optimize) #'(new ...)))
|
||||||
#,safe-fallback))))))
|
#,safe-fallback))))))
|
||||||
;; similarly for flvectors
|
;; similarly for flvectors
|
||||||
(pattern (#%plain-app op:flvector-op v:expr i:fixnum-expr new:expr ...)
|
(pattern (#%plain-app op:flvector-op v:expr i:fixnum-expr new:expr ...)
|
||||||
|
@ -112,7 +112,7 @@
|
||||||
"Partial bounds checking elimination."
|
"Partial bounds checking elimination."
|
||||||
this-syntax)
|
this-syntax)
|
||||||
(add-disappeared-use #'op)
|
(add-disappeared-use #'op)
|
||||||
(let ([safe-fallback #`(op new-v new-i #,@(syntax-map (optimize) #'(new ...)))]
|
(let ([safe-fallback #`(op new-v new-i #,@(stx-map (optimize) #'(new ...)))]
|
||||||
[i-known-nonneg? (subtypeof? #'i -NonNegFixnum)])
|
[i-known-nonneg? (subtypeof? #'i -NonNegFixnum)])
|
||||||
#`(let ([new-i #,((optimize) #'i)]
|
#`(let ([new-i #,((optimize) #'i)]
|
||||||
[new-v #,((optimize) #'v)])
|
[new-v #,((optimize) #'v)])
|
||||||
|
@ -121,5 +121,5 @@
|
||||||
one-sided
|
one-sided
|
||||||
#`(and (unsafe-fx>= new-i 0)
|
#`(and (unsafe-fx>= new-i 0)
|
||||||
#,one-sided)))
|
#,one-sided)))
|
||||||
(op.unsafe new-v new-i #,@(syntax-map (optimize) #'(new ...)))
|
(op.unsafe new-v new-i #,@(stx-map (optimize) #'(new ...)))
|
||||||
#,safe-fallback))))))
|
#,safe-fallback))))))
|
||||||
|
|
|
@ -10,7 +10,7 @@
|
||||||
syntax/free-vars
|
syntax/free-vars
|
||||||
(typecheck signatures tc-metafunctions tc-subst check-below)
|
(typecheck signatures tc-metafunctions tc-subst check-below)
|
||||||
racket/match (contract-req)
|
racket/match (contract-req)
|
||||||
syntax/kerncase syntax/parse unstable/syntax
|
syntax/kerncase syntax/parse syntax/stx
|
||||||
(for-template racket/base (typecheck internal-forms)))
|
(for-template racket/base (typecheck internal-forms)))
|
||||||
|
|
||||||
|
|
||||||
|
@ -202,9 +202,7 @@
|
||||||
(cond [(andmap (lambda (fv)
|
(cond [(andmap (lambda (fv)
|
||||||
(or (not (s:member fv letrec-bound-ids bound-identifier=?)) ; from outside
|
(or (not (s:member fv letrec-bound-ids bound-identifier=?)) ; from outside
|
||||||
(s:member fv transitively-safe-bindings bound-identifier=?)))
|
(s:member fv transitively-safe-bindings bound-identifier=?)))
|
||||||
(apply append
|
(apply append (stx-map free-vars clause-rhs)))
|
||||||
(syntax-map (lambda (x) (free-vars x))
|
|
||||||
clause-rhs)))
|
|
||||||
'transitively-safe]
|
'transitively-safe]
|
||||||
[else
|
[else
|
||||||
(syntax-parse clause-rhs #:literal-sets (kernel-literals)
|
(syntax-parse clause-rhs #:literal-sets (kernel-literals)
|
||||||
|
|
|
@ -2,8 +2,8 @@
|
||||||
|
|
||||||
(require (for-syntax racket/base
|
(require (for-syntax racket/base
|
||||||
syntax/parse
|
syntax/parse
|
||||||
|
syntax/stx
|
||||||
racket/syntax
|
racket/syntax
|
||||||
unstable/syntax
|
|
||||||
typed-racket/utils/tc-utils)
|
typed-racket/utils/tc-utils)
|
||||||
typed-racket/utils/tc-utils)
|
typed-racket/utils/tc-utils)
|
||||||
|
|
||||||
|
@ -32,7 +32,7 @@
|
||||||
(typed/untyped-renamer #'typed-name #'untyped-name)))]))
|
(typed/untyped-renamer #'typed-name #'untyped-name)))]))
|
||||||
|
|
||||||
(define-for-syntax (freshen ids)
|
(define-for-syntax (freshen ids)
|
||||||
(syntax-map (lambda (id) ((make-syntax-introducer) id)) ids))
|
(stx-map (lambda (id) ((make-syntax-introducer) id)) ids))
|
||||||
|
|
||||||
(define-syntax (require/untyped-contract stx)
|
(define-syntax (require/untyped-contract stx)
|
||||||
(syntax-parse stx #:literals (begin)
|
(syntax-parse stx #:literals (begin)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user