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

for: optimize literals

Browse Source 
Closes #883
This commit is contained in:
sorawee 2020-09-15 09:43:57 -07:00 committed by GitHub
parent d307a514b1
commit 6366874ecd
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
2 changed files with 93 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
pkgs/racket-test-core/tests/racket/for.rktl
View File

@ -1154,6 +1154,54 @@
(test (void) 'for/foldr-result-delay-2 (force result))
(test #t 'for/foldr-result-delay-3 evaluated?))
;; same expansion (from @soegaard)
(let ()
(test #t 'same-expansion-for-integer-clause
(equal? (syntax->datum (expand #'(for ([j 100]) j)))
(syntax->datum (expand #'(for ([j (in-range 100)]) j)))))
(test #t 'same-expansion-for-list-clause
(equal? (syntax->datum (expand #'(for ([j '(1 2 3)]) j)))
(syntax->datum (expand #'(for ([j (in-list '(1 2 3))]) j)))))
(test #t 'same-expansion-for-vector-clause
(equal? (syntax->datum (expand #'(for ([j #(1 2 3)]) j)))
(syntax->datum (expand #'(for ([j (in-vector #(1 2 3))]) j)))))
(test #t 'same-expansion-for-hash-clause
(equal? (syntax->datum (expand #'(for ([(i j) #hash((1 . 2) (3 . 4))]) j)))
(syntax->datum (expand #'(for ([(i j) (in-immutable-hash #hash((1 . 2) (3 . 4)))]) j)))))
(test #t 'same-expansion-for-string-clause
(equal? (syntax->datum (expand #'(for ([j "abc"]) j)))
(syntax->datum (expand #'(for ([j (in-string "abc")]) j)))))
(test #t 'same-expansion-for-bytes-clause
(equal? (syntax->datum (expand #'(for ([j #"abc"]) j)))
(syntax->datum (expand #'(for ([j (in-bytes #"abc")]) j))))))
;; #%datum is picked up (from @gus-massa)
(let ()
(local-require (only-in racket (#%datum #%old-datum)))
(define-syntax-rule (#%datum . x) (#%old-datum . 3))
(test-sequence [(0 1 2)] 5))
;; for expanded in expression context
(module test-for-expansion racket
(provide foo%)
(define foo%
(class object%
(super-new)
(define/public (bar) 1)
(for ([x (bar)]) #t))))
(let ()
(local-require 'test-for-expansion)
(test #t object? (new foo%)))
(err/rt-test (for/list ([x -1]) x))
(err/rt-test (for/list ([x 1.5]) x))
;; ----------------------------------------
(report-errs)

50
racket/collects/racket/private/for.rkt
View File

@ -234,7 +234,8 @@
[(_ rhs)
(lambda (stx)
(syntax-rearm stx #'rhs))]))
(let eloop ([use-transformer? #t])
;; expanded-rhs :: (or/c #f syntax?)
(let eloop ([use-transformer? #t] [expanded-rhs #f])
(define unpacked-clause (unpack clause))
(syntax-case unpacked-clause (values in-parallel stop-before stop-after :do-in)
[[(id ...) rhs]
@ -258,7 +259,7 @@
(cons (syntax-local-introduce #'form)
(or (syntax-property r 'disappeared-use)
null))))
(eloop #f)))))]
(eloop #f #f)))))]
[[(id ...) (:do-in . body)]
(syntax-case #'body ()
[(([(outer-id ...) outer-rhs] ...)
@ -333,7 +334,7 @@
(and post-guard (not (pred id ...)))
(loop-arg ...)))]
[[(id ...) rhs]
#t
expanded-rhs
(let ([introducer (make-syntax-introducer)])
;; log non-specialized clauses, for performance tuning
(when (log-level? sequence-specialization-logger 'debug)
@ -344,14 +345,15 @@
(syntax-line #'rhs)
(syntax-column #'rhs))
#'rhs))
(with-syntax ([[(id ...) rhs] (introducer (syntax-local-introduce clause))])
(with-syntax ([[(id ...) rhs*]
(introducer (syntax-local-introduce #`[(id ...) #,expanded-rhs]))])
(with-syntax ([(post-id ...) (generate-temporaries #'(id ...))])
(arm-for-clause
(syntax-local-introduce
(introducer
#`(([(pos->vals pos-pre-inc pos-next init pos-cont? val-cont? all-cont?)
#,(syntax-property
(syntax/loc #'rhs (make-sequence '(id ...) rhs))
(syntax/loc #'rhs (make-sequence '(id ...) rhs*))
'feature-profile:generic-sequence #t)])
(void)
([pos init])
@ -382,6 +384,40 @@
(syntax/loc #'rhs ((pos-next pos)))
'feature-profile:generic-sequence #t))))
(make-rearm)))))]
[[(id ...) rhs]
(with-syntax ([expanded-rhs (syntax-disarm (local-expand #'rhs 'expression (list #'quote)) orig-insp)])
(syntax-case #'expanded-rhs (quote)
[(quote e)
(let ([content (syntax-e #'e)])
(cond
[(exact-nonnegative-integer? content)
(expand-clause orig-stx (arm-for-clause
#'[(id ...) (*in-range e)]
(make-rearm)))]
[(list? content)
(expand-clause orig-stx (arm-for-clause
;; list is the only case we need to specifically quote it
;; because it would turn into a function application otherwise
#'[(id ...) (*in-list expanded-rhs)]
(make-rearm)))]
[(vector? content)
(expand-clause orig-stx (arm-for-clause
#'[(id ...) (*in-vector e)]
(make-rearm)))]
[(and (hash? content) (immutable? content))
(expand-clause orig-stx (arm-for-clause
#'[(id ...) (in-immutable-hash e)]
(make-rearm)))]
[(string? content)
(expand-clause orig-stx (arm-for-clause
#'[(id ...) (*in-string e)]
(make-rearm)))]
[(bytes? content)
(expand-clause orig-stx (arm-for-clause
#'[(id ...) (*in-bytes e)]
(make-rearm)))]
[else (eloop #f #'expanded-rhs)]))]
[_ (eloop #f #'expanded-rhs)]))]
[_
(raise-syntax-error #f
"bad sequence binding clause" orig-stx clause)]))))
@ -1489,6 +1525,10 @@
(define-syntax (for/foldX/derived stx)
(syntax-case stx ()
;; Force expression context
[_
(not (eq? 'expression (syntax-local-context)))
#`(#%expression #,stx)]
;; Done case (no more clauses, and no generated clauses to emit):
[(_ [orig-stx inner-recur nested? emit? ()] ([fold-var fold-init] ...) next-k break-k final?-id ()
expr1 expr ...)