From 6366874ecda44f557afef1037a814e9827ed92a4 Mon Sep 17 00:00:00 2001 From: sorawee Date: Tue, 15 Sep 2020 09:43:57 -0700 Subject: [PATCH] for: optimize literals Closes #883 --- pkgs/racket-test-core/tests/racket/for.rktl | 48 ++++++++++++++++++++ racket/collects/racket/private/for.rkt | 50 ++++++++++++++++++--- 2 files changed, 93 insertions(+), 5 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/for.rktl b/pkgs/racket-test-core/tests/racket/for.rktl index e01bdc9fa9..5ef2014712 100644 --- a/pkgs/racket-test-core/tests/racket/for.rktl +++ b/pkgs/racket-test-core/tests/racket/for.rktl @@ -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) diff --git a/racket/collects/racket/private/for.rkt b/racket/collects/racket/private/for.rkt index dd57aa2990..f7dcd00faf 100644 --- a/racket/collects/racket/private/for.rkt +++ b/racket/collects/racket/private/for.rkt @@ -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 ...)