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

reverse and map: skip checks in unsafe mode

Browse Source 
Since only the expander is compiled in unsafe mode right now, the
checks are skipped only when the implementations of `reverse`, `map`,
etc., are part of the flattened expander.
This commit is contained in:
Matthew Flatt 2018-03-19 10:11:48 -06:00
parent b82d6e2204
commit f138469464
6 changed files with 9375 additions and 9321 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
racket/collects/racket/private/map.rkt
View File

@ -5,13 +5,26 @@
(module map '#%kernel
(#%require "small-scheme.rkt" "define.rkt"
"performance-hint.rkt"
'#%paramz)
'#%paramz
(for-syntax '#%kernel))
(#%provide (rename map2 map)
(rename for-each2 for-each)
(rename andmap2 andmap)
(rename ormap2 ormap))
(define-syntaxes (or-unsafe)
(lambda (stx)
(let-values ([(es) (cdr (syntax-e stx))])
(let-values ([(e) (car (if (syntax? es)
(syntax-e es)
es))])
(datum->syntax #f
(list (quote-syntax if)
(quote-syntax (variable-reference-from-unsafe? (#%variable-reference)))
(quote-syntax #t)
e))))))
;; -------------------------------------------------------------------------
(begin-encourage-inline
@ -20,9 +33,9 @@
(let ([map
(case-lambda
[(f l)
(if (and (procedure? f)
(procedure-arity-includes? f 1)
(list? l))
(if (or-unsafe (and (procedure? f)
(procedure-arity-includes? f 1)
(list? l)))
(let loop ([l l])
(cond
[(null? l) null]
@ -31,11 +44,12 @@
(cons (f (car l)) (loop r)))]))
(gen-map f (list l)))]
[(f l1 l2)
(if (and (procedure? f)
(procedure-arity-includes? f 2)
(list? l1)
(list? l2)
(= (length l1) (length l2)))
(if (or-unsafe
(and (procedure? f)
(procedure-arity-includes? f 2)
(list? l1)
(list? l2)
(= (length l1) (length l2))))
(let loop ([l1 l1] [l2 l2])
(cond
[(null? l1) null]
@ -52,9 +66,10 @@
(let ([for-each
(case-lambda
[(f l)
(if (and (procedure? f)
(procedure-arity-includes? f 1)
(list? l))
(if (or-unsafe
(and (procedure? f)
(procedure-arity-includes? f 1)
(list? l)))
(let loop ([l l])
(cond
[(null? l) (void)]
@ -63,11 +78,12 @@
(begin (f (car l)) (loop r)))]))
(gen-for-each f (list l)))]
[(f l1 l2)
(if (and (procedure? f)
(procedure-arity-includes? f 2)
(list? l1)
(list? l2)
(= (length l1) (length l2)))
(if (or-unsafe
(and (procedure? f)
(procedure-arity-includes? f 2)
(list? l1)
(list? l2)
(= (length l1) (length l2))))
(let loop ([l1 l1] [l2 l2])
(cond
[(null? l1) (void)]
@ -84,9 +100,10 @@
(let ([andmap
(case-lambda
[(f l)
(if (and (procedure? f)
(procedure-arity-includes? f 1)
(list? l))
(if (or-unsafe
(and (procedure? f)
(procedure-arity-includes? f 1)
(list? l)))
(if (null? l)
#t
(let loop ([l l])
@ -98,11 +115,12 @@
(loop r)))])))
(gen-andmap f (list l)))]
[(f l1 l2)
(if (and (procedure? f)
(procedure-arity-includes? f 2)
(list? l1)
(list? l2)
(= (length l1) (length l2)))
(if (or-unsafe
(and (procedure? f)
(procedure-arity-includes? f 2)
(list? l1)
(list? l2)
(= (length l1) (length l2))))
(if (null? l1)
#t
(let loop ([l1 l1] [l2 l2])
@ -121,9 +139,10 @@
(let ([ormap
(case-lambda
[(f l)
(if (and (procedure? f)
(procedure-arity-includes? f 1)
(list? l))
(if (or-unsafe
(and (procedure? f)
(procedure-arity-includes? f 1)
(list? l)))
(if (null? l)
#f
(let loop ([l l])
@ -134,11 +153,12 @@
(or (f (car l)) (loop r)))])))
(gen-ormap f (list l)))]
[(f l1 l2)
(if (and (procedure? f)
(procedure-arity-includes? f 2)
(list? l1)
(list? l2)
(= (length l1) (length l2)))
(if (or-unsafe
(and (procedure? f)
(procedure-arity-includes? f 2)
(list? l1)
(list? l2)
(= (length l1) (length l2))))
(if (null? l1)
#f
(let loop ([l1 l1] [l2 l2])
@ -209,7 +229,7 @@
null))))))
(define (gen-map f ls)
(check-args 'map f ls)
(or-unsafe (check-args 'map f ls))
(let loop ([ls ls])
(cond
[(null? (car ls)) null]
@ -219,7 +239,7 @@
(loop next-ls)))])))
(define (gen-for-each f ls)
(check-args 'for-each f ls)
(or-unsafe (check-args 'for-each f ls))
(let loop ([ls ls])
(unless (null? (car ls))
(let ([next-ls (map2 cdr ls)])
@ -227,7 +247,7 @@
(loop next-ls)))))
(define (gen-andmap f ls)
(check-args 'andmap f ls)
(or-unsafe (check-args 'andmap f ls))
(let loop ([ls ls])
(cond
[(null? (car ls)) #t]
@ -237,7 +257,7 @@
(loop next-ls)))])))
(define (gen-ormap f ls)
(check-args 'ormap f ls)
(or-unsafe (check-args 'ormap f ls))
(let loop ([ls ls])
(cond
[(null? (car ls)) #f]

6
racket/collects/racket/private/reverse.rkt
View File

@ -3,9 +3,11 @@
(define-values (reverse)
(lambda (l)
(if (list? l)
(if (variable-reference-from-unsafe? (#%variable-reference))
(void)
(raise-argument-error 'reverse "list?" l))
(if (list? l)
(void)
(raise-argument-error 'reverse "list?" l)))
(letrec-values ([(loop)
(lambda (a l)
(if (null? l)

2
racket/src/expander/expand/free-id-set.rkt
View File

@ -22,7 +22,7 @@
(eq? fs empty-free-id-set))
(define (free-id-set-member? fs phase given-id)
(if (zero? (hash-count fs))
(if (free-id-set-empty? fs)
#f
(for/or ([id (in-list-ish (hash-ref fs
(identifier-binding-symbol given-id phase)

27
racket/src/expander/expand/main.rkt
View File

@ -72,10 +72,10 @@
#:skip-log? [skip-log? #f])
(log-expand* ctx #:unless skip-log? [(if (expand-context-only-immediate? ctx) 'enter-check 'visit) s])
(cond
[(identifier? s)
[(syntax-identifier? s)
(expand-identifier s ctx alternate-id)]
[(and (pair? (syntax-content s))
(identifier? (car (syntax-content s))))
(syntax-identifier? (car (syntax-content s))))
(expand-id-application-form s ctx alternate-id)]
[(or (pair? (syntax-content s))
(null? (syntax-content s)))
@ -369,7 +369,7 @@
;; any expansion result
(define post-s (maybe-add-post-expansion-scope result-s ctx))
;; Track expansion:
(define tracked-s (syntax-track-origin post-s cleaned-s (or origin-id (if (identifier? s) s (car (syntax-e s))))))
(define tracked-s (syntax-track-origin post-s cleaned-s (or origin-id (if (syntax-identifier? s) s (car (syntax-e s))))))
(define rearmed-s (taint-dispatch tracked-s (lambda (t-s) (syntax-rearm t-s s)) (expand-context-phase ctx)))
(log-expand ctx 'exit-macro rearmed-s)
(values rearmed-s
@ -476,19 +476,20 @@
(define-syntax-rule (guard-stop id ctx s otherwise ...)
(cond
[(free-id-set-member? (expand-context-stops ctx)
(expand-context-phase ctx)
id)
(log-expand* ctx #:unless (expand-context-only-immediate? ctx)
['resolve id] ['enter-prim s] ['prim-stop] ['exit-prim s] ['return s])
s]
[else
otherwise ...]))
[(and (not (free-id-set-empty? (expand-context-stops ctx)))
(free-id-set-member? (expand-context-stops ctx)
(expand-context-phase ctx)
id))
(log-expand* ctx #:unless (expand-context-only-immediate? ctx)
['resolve id] ['enter-prim s] ['prim-stop] ['exit-prim s] ['return s])
s]
[else
otherwise ...]))
(define (substitute-alternate-id s alternate-id)
(cond
[(not alternate-id) s]
[(identifier? s) (syntax-rearm (syntax-track-origin alternate-id s) s)]
[(syntax-identifier? s) (syntax-rearm (syntax-track-origin alternate-id s) s)]
[else
(define disarmed-s (syntax-disarm s))
(syntax-rearm (syntax-track-origin (datum->syntax
@ -686,7 +687,7 @@
(define d (syntax-e s))
(define keep-e (cond
[(symbol? d) d]
[(and (pair? d) (identifier? (car d))) (syntax-e (car d))]
[(and (pair? d) (syntax-identifier? (car d))) (syntax-e (car d))]
[else #f]))
(cond
[(expand-context-to-parsed? ctx)

4
racket/src/expander/syntax/syntax.rkt
View File

@ -12,6 +12,7 @@
syntax-tamper
empty-syntax
identifier?
syntax-identifier?
syntax->datum
datum->syntax
@ -177,6 +178,9 @@
(define (identifier? s)
(and (syntax? s) (symbol? (syntax-content s))))
(define (syntax-identifier? s) ; assumes that `s` is syntax
(symbol? (syntax-content s)))
(define (syntax->datum s)
(syntax-map s (lambda (tail? x) x) (lambda (s d) d) syntax-content))

18561
racket/src/racket/src/startup.inc
View File

File diff suppressed because it is too large Load Diff