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

map + syntax->list -> syntax-map

Browse Source
This commit is contained in:
Vincent St-Amour 2010-12-08 14:29:19 -05:00
parent b7588b0081
commit 33581fd67e
7 changed files with 59 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/typed-scheme/optimizer/box.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require syntax/parse (require syntax/parse unstable/syntax
racket/match racket/match
"../utils/utils.rkt" "../utils/utils.rkt"
(for-template scheme/base scheme/unsafe/ops) (for-template scheme/base scheme/unsafe/ops)
@ -29,4 +29,4 @@
(pattern (#%plain-app op:box-op b:box-expr new:expr ...) (pattern (#%plain-app op:box-op b:box-expr new:expr ...)
#:with opt #:with opt
(begin (log-optimization "box" #'op) (begin (log-optimization "box" #'op)
#`(op.unsafe b.opt #,@(map (optimize) (syntax->list #'(new ...))))))) #`(op.unsafe b.opt #,@(syntax-map (optimize) #'(new ...))))))

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

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require syntax/parse syntax/id-table scheme/dict (require syntax/parse syntax/id-table scheme/dict unstable/syntax
"../utils/utils.rkt" racket/unsafe/ops "../utils/utils.rkt" racket/unsafe/ops
(for-template scheme/base scheme/math racket/flonum scheme/unsafe/ops) (for-template scheme/base scheme/math racket/flonum scheme/unsafe/ops)
(types abbrev) (types abbrev)
@ -71,8 +71,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 (map (lambda (x) (if (syntax->datum x) x #'0.0)) (let* ((l1 (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0)) l))
(syntax->list 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))))
@ -98,19 +97,19 @@
#`(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 (map (lambda (x) (if (syntax->datum x) x #'0.0)) #,@(let ((lr (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.real-binding c2.real-binding cs.real-binding ...)))) #'(c1.real-binding c2.real-binding cs.real-binding ...)))
(li (map (lambda (x) (if (syntax->datum x) x #'0.0)) (li (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(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 (map (lambda (x) (unboxed-gensym "unboxed-real-")) [rs (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
(syntax->list #'(cs.real-binding ...))) #'(cs.real-binding ...))
(list #'real-binding))] (list #'real-binding))]
[is (append (map (lambda (x) (unboxed-gensym "unboxed-imag-")) [is (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
(syntax->list #'(cs.imag-binding ...))) #'(cs.imag-binding ...))
(list #'imag-binding))] (list #'imag-binding))]
[res '()]) [res '()])
(if (null? e1) (if (null? e1)
@ -142,10 +141,10 @@
#:when (or (isoftype? this-syntax -FloatComplex) (isoftype? this-syntax -Number)) #:when (or (isoftype? this-syntax -FloatComplex) (isoftype? this-syntax -Number))
#: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 (map (lambda (x) (if (syntax->datum x) x #'0.0)) #:with reals (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.real-binding c2.real-binding cs.real-binding ...))) #'(c1.real-binding c2.real-binding cs.real-binding ...))
#:with imags (map (lambda (x) (if (syntax->datum x) x #'0.0)) #:with imags (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(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" #'op) (begin (log-optimization "unboxed binary float complex" #'op)
#`(c1.bindings ... c2.bindings ... cs.bindings ... ... #`(c1.bindings ... c2.bindings ... cs.bindings ... ...
@ -155,14 +154,14 @@
[o2 (car (syntax->list #'imags))] [o2 (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 (map (lambda (x) (unboxed-gensym "unboxed-real-")) [rs (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
(syntax->list #'(cs.real-binding ...))) #'(cs.real-binding ...))
(list #'real-binding))] (list #'real-binding))]
[is (append (map (lambda (x) (unboxed-gensym "unboxed-imag-")) [is (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
(syntax->list #'(cs.imag-binding ...))) #'(cs.imag-binding ...))
(list #'imag-binding))] (list #'imag-binding))]
[ds (map (lambda (x) (unboxed-gensym)) [ds (syntax-map (lambda (x) (unboxed-gensym))
(syntax->list #'(c2.real-binding cs.real-binding ...)))] #'(c2.real-binding cs.real-binding ...))]
[res '()]) [res '()])
(if (null? e1) (if (null? e1)
(reverse res) (reverse res)

30
collects/typed-scheme/optimizer/optimizer.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require syntax/parse (require syntax/parse unstable/syntax
racket/pretty racket/pretty
(for-template scheme/base) (for-template scheme/base)
"../utils/utils.rkt" "../utils/utils.rkt"
@ -37,41 +37,41 @@
;; 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 #`(op formals #,@(map (optimize) (syntax->list #'(e ...))))) #:with opt #`(op formals #,@(syntax-map (optimize) #'(e ...))))
(pattern (case-lambda [formals e:expr ...] ...) (pattern (case-lambda [formals e:expr ...] ...)
;; optimize all the bodies ;; optimize all the bodies
#:with (opt-parts ...) #:with (opt-parts ...)
(map (lambda (part) (syntax-map (lambda (part)
(let ((l (syntax->list part))) (let ((l (syntax->list part)))
(cons (car l) (cons (car l)
(map (optimize) (cdr l))))) (map (optimize) (cdr l)))))
(syntax->list #'([formals e ...] ...))) #'([formals e ...] ...))
#:with opt #'(case-lambda opt-parts ...)) #:with opt #'(case-lambda 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 ...) (map (optimize) (syntax->list #'(e-rhs ...))) #:with (opt-rhs ...) (syntax-map (optimize) #'(e-rhs ...))
#:with opt #`(op ([ids opt-rhs] ...) #:with opt #`(op ([ids opt-rhs] ...)
#,@(map (optimize) (syntax->list #'(e-body ...))))) #,@(syntax-map (optimize) #'(e-body ...))))
(pattern (letrec-syntaxes+values stx-bindings (pattern (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 ...)
(map (lambda (clause) (syntax-map (lambda (clause)
(let ((l (syntax->list clause))) (let ((l (syntax->list clause)))
(list (car l) ((optimize) (cadr l))))) (list (car l) ((optimize) (cadr l)))))
(syntax->list #'([(ids ...) e-rhs] ...))) #'([(ids ...) e-rhs] ...))
#:with opt #`(letrec-syntaxes+values #:with opt #`(letrec-syntaxes+values
stx-bindings stx-bindings
(opt-clauses ...) (opt-clauses ...)
#,@(map (optimize) (syntax->list #'(e-body ...))))) #,@(syntax-map (optimize) #'(e-body ...))))
(pattern (kw:identifier expr ...) (pattern (kw:identifier expr ...)
#:when #:when
(for/or ([k (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression (for/or ([k (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
#'#%variable-reference #'with-continuation-mark)]) #'#%variable-reference #'with-continuation-mark)])
(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 #`(kw #,@(map (optimize) (syntax->list #'(expr ...))))) #:with opt #`(kw #,@(syntax-map (optimize) #'(expr ...))))
(pattern other:expr (pattern other:expr
#:with opt #'other)) #:with opt #'other))

4
collects/typed-scheme/optimizer/pair.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require syntax/parse (require syntax/parse unstable/syntax
racket/match racket/match
(for-template scheme/base scheme/unsafe/ops) (for-template scheme/base scheme/unsafe/ops)
"../utils/utils.rkt" "../utils/utils.rkt"
@ -52,7 +52,7 @@
(pattern (#%plain-app op:mpair-op p:mpair-expr e:expr ...) (pattern (#%plain-app op:mpair-op p:mpair-expr e:expr ...)
#:with opt #:with opt
(begin (log-optimization "mutable pair" #'op) (begin (log-optimization "mutable pair" #'op)
#`(op.unsafe p.opt #,@(map (optimize) (syntax->list #'(e ...))))))) #`(op.unsafe p.opt #,@(syntax-map (optimize) #'(e ...))))))
;; if the equivalent sequence of cars and cdrs is guaranteed not to fail, ;; if the equivalent sequence of cars and cdrs is guaranteed not to fail,

4
collects/typed-scheme/optimizer/struct.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require syntax/parse (require syntax/parse unstable/syntax
(for-template scheme/base scheme/unsafe/ops) (for-template scheme/base scheme/unsafe/ops)
"../utils/utils.rkt" "../utils/utils.rkt"
(types type-table) (types type-table)
@ -21,4 +21,4 @@
#`(unsafe-struct-ref #,((optimize) #'s) #,idx)) #`(unsafe-struct-ref #,((optimize) #'s) #,idx))
(begin (log-optimization "struct set" #'op) (begin (log-optimization "struct set" #'op)
#`(unsafe-struct-set! #,((optimize) #'s) #,idx #`(unsafe-struct-set! #,((optimize) #'s) #,idx
#,@(map (optimize) (syntax->list #'(v ...))))))))) #,@(syntax-map (optimize) #'(v ...))))))))

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

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require syntax/parse (require syntax/parse unstable/syntax
scheme/list scheme/dict racket/match scheme/list scheme/dict racket/match
"../utils/utils.rkt" "../utils/utils.rkt"
"../utils/tc-utils.rkt" "../utils/tc-utils.rkt"
@ -62,7 +62,7 @@
(and (isoftype? (cadr p) -FloatComplex) (and (isoftype? (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 ...))))
(map syntax->list (syntax->list #'(clause ...))))) (syntax-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
@ -142,7 +142,7 @@
(opt-candidates.bindings ... ... (opt-candidates.bindings ... ...
opt-functions.res ... opt-functions.res ...
opt-others.res ...) opt-others.res ...)
#,@(map (optimize) (syntax->list #'(body ...))))))) #,@(syntax-map (optimize) #'(body ...))))))
(define-splicing-syntax-class let-like-keyword (define-splicing-syntax-class let-like-keyword
#:commit #:commit
@ -185,13 +185,13 @@
([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)
(map (syntax-parser (syntax-map (syntax-parser
[((id) rhs) [((id) rhs)
#:when (and (identifier? #'rhs) #:when (and (identifier? #'rhs)
(free-identifier=? v #'rhs)) (free-identifier=? v #'rhs))
#'id] #'id]
[_ #f]) [_ #f])
(syntax->list #'((ids e-rhs) ...)))) #'((ids e-rhs) ...)))
(or (look-at #'(e-rhs ... e-body ...)) (or (look-at #'(e-rhs ... e-body ...))
(ormap (lambda (x) (could-be-unboxed-in? x exp)) (ormap (lambda (x) (could-be-unboxed-in? x exp))
(syntax->list #'rebindings)))] (syntax->list #'rebindings)))]
@ -288,15 +288,15 @@
#:when (syntax->datum #'unboxed-info) #:when (syntax->datum #'unboxed-info)
;; partition of the arguments ;; partition of the arguments
#:with ((to-unbox ...) (boxed ...)) #'unboxed-info #:with ((to-unbox ...) (boxed ...)) #'unboxed-info
#:with (real-params ...) (map (lambda (x) (unboxed-gensym "unboxed-real-")) #:with (real-params ...) (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-"))
(syntax->list #'(to-unbox ...))) #'(to-unbox ...))
#:with (imag-params ...) (map (lambda (x) (unboxed-gensym "unboxed-imag-")) #:with (imag-params ...) (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-"))
(syntax->list #'(to-unbox ...))) #'(to-unbox ...))
#:with res #:with res
(begin (begin
(log-optimization "fun -> unboxed fun" #'v) (log-optimization "fun -> unboxed fun" #'v)
;; add unboxed parameters to the unboxed vars table ;; add unboxed parameters to the unboxed vars table
(let ((to-unbox (map syntax->datum (syntax->list #'(to-unbox ...))))) (let ((to-unbox (syntax-map 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 ...)))
@ -308,7 +308,7 @@
;; be inserted when optimizing the body ;; be inserted when optimizing the body
#`((v) (#%plain-lambda #`((v) (#%plain-lambda
(real-params ... imag-params ... #,@(reverse boxed)) (real-params ... imag-params ... #,@(reverse boxed))
#,@(map (optimize) (syntax->list #'(body ...)))))] #,@(syntax-map (optimize) #'(body ...))))]
[(memq i to-unbox) ; we unbox the current param, add to the table [(memq i to-unbox) ; we unbox the current param, add to the table
(dict-set! unboxed-vars-table (car params) (dict-set! unboxed-vars-table (car params)

4
collects/typed-scheme/optimizer/vector.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require syntax/parse (require syntax/parse unstable/syntax
racket/match racket/match
(for-template scheme/base racket/flonum scheme/unsafe/ops) (for-template scheme/base racket/flonum scheme/unsafe/ops)
"../utils/utils.rkt" "../utils/utils.rkt"
@ -63,4 +63,4 @@
#:with opt #:with opt
(begin (log-optimization "vector" #'op) (begin (log-optimization "vector" #'op)
#`(op.unsafe v.opt #,((optimize) #'i) #`(op.unsafe v.opt #,((optimize) #'i)
#,@(map (optimize) (syntax->list #'(new ...))))))) #,@(syntax-map (optimize) #'(new ...))))))