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

add procedure-arity-mask and procedure-reduce-arity-mask

Browse Source 
The mask encoding of an arity is often easier to test and manipulate,
and masked-based functions are sometimes faster than functions that
used the old arity representation (while always being at least as
fast).

Attempting to assign an arity like `(expt 2 100)` to `(lambda x x)`
won't work anymore; it will raise an out-of-memory exception, because
the arity is represented internally as a mask. The arities that cannot
be represented aren't sensible arities, anyway.
This commit is contained in:
Matthew Flatt 2018-08-09 06:23:27 -06:00
parent 36204b00ca
commit ecbd6f1578
27 changed files with 785 additions and 432 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "7.0.0.10")
(define version "7.0.0.11")
(define deps `("racket-lib"
["racket" #:version ,version]))

11
pkgs/racket-doc/scribblings/reference/exns.scrbl
View File

@ -316,6 +316,17 @@ message.
]}
@defproc[(raise-arity-mask-error [name (or/c symbol? procedure?)]
[mask exact-integer?]
[arg-v any/c] ...)
any]{
The same as @racket[raise-arity-error], but using the arity representation
described with @racket[procedure-arity-mask].
@history[#:added "7.0.0.11"]}
@defproc[(raise-result-arity-error [name (or/c symbol? #f)]
[arity-v exact-nonnegative-integer?]
[detail-str (or/c string? #f)]

48
pkgs/racket-doc/scribblings/reference/procedures.scrbl
View File

@ -135,8 +135,8 @@ the @exnraise[exn:fail:contract].
@defproc[(procedure-arity [proc procedure?]) normalized-arity?]{
Returns information about the number of by-position arguments accepted
by @racket[proc]. See also @racket[procedure-arity?] and
@racket[normalized-arity?].}
by @racket[proc]. See also @racket[procedure-arity?],
@racket[normalized-arity?], and @racket[procedure-arity-mask].}
@defproc[(procedure-arity? [v any/c]) boolean?]{
@ -169,6 +169,19 @@ The result of @racket[procedure-arity] is always normalized in the sense of
(procedure-arity (case-lambda [(x) 0] [(x y) 1]))
]}
@defproc[(procedure-arity-mask [proc procedure?]) exact-integer?]{
Returns the same information as @racket[procedure-arity], but encoded
differently. The arity is encoded as an exact integer @racket[_mask]
where @racket[(bitwise-bit-set? _mask _n)] returns true if @racket[proc]
accepts @racket[_n] arguments.
The mask encoding of an arity is often easier to test and manipulate,
and @racket[procedure-arity-mask] is sometimes faster than
@racket[procedure-arity] while always being at least as fast.
@history[#:added "7.0.0.11"]}
@defproc[(procedure-arity-includes? [proc procedure?]
[k exact-nonnegative-integer?]
[kws-ok? any/c #f])
@ -187,7 +200,8 @@ keyword arguments.
]}
@defproc[(procedure-reduce-arity [proc procedure?]
[arity procedure-arity?])
[arity procedure-arity?]
[name (or/c symbol? #f) #f])
procedure?]{
Returns a procedure that is the same as @racket[proc] (including
@ -195,7 +209,7 @@ the same name returned by @racket[object-name]), but that accepts
only arguments consistent with @racket[arity]. In particular,
when @racket[procedure-arity] is applied to the generated
procedure, it returns a value that is @racket[equal?] to
@racket[arity].
the normalized form of @racket[arity].
If the @racket[arity] specification allows arguments that are not in
@racket[(procedure-arity proc)], the @exnraise[exn:fail:contract]. If
@ -205,11 +219,35 @@ arity-reduced procedure) or @racket[arity] must be the empty list
(which makes a procedure that cannot be called); otherwise, the
@exnraise[exn:fail:contract].
If @racket[name] is not @racket[#f], then @racket[object-name] of the
result procedure produces @racket[name]. Otherwise,
@racket[object-name] of the result procedure produces the same result
as for @racket[proc].
@examples[
(define my+ (procedure-reduce-arity + 2 ))
(my+ 1 2)
(eval:error (my+ 1 2 3))
]}
(define also-my+ (procedure-reduce-arity + 2 'also-my+))
(eval:error (also-my+ 1 2 3))
]
@history[#:changed "7.0.0.11" @elem{Added the optional @racket[name]
argument.}]}
@defproc[(procedure-reduce-arity-mask [proc procedure?]
[mask exact-integer?]
[name (or/c symbol? #f) #f])
procedure?]{
The same as @racket[procedure-reduce-arity-mask], but using the
representation of arity described with @racket[procedure-arity-mask].
The mask encoding of an arity is often easier to test and manipulate,
and @racket[procedure-reduce-arity-mask] is sometimes faster than
@racket[procedure-reduce-arity] while always being at least as fast.
@history[#:added "7.0.0.11"]}
@defproc[(procedure-keywords [proc procedure?])
(values

13
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -2149,6 +2149,16 @@
(err/rt-test (raise-result-arity-error 'f -7 #f) exn:fail:contract:arity?/#f)
(err/rt-test (raise-result-arity-error 'f 7 #"oops") exn:fail:contract:arity?/#f)
(err/rt-test (raise-arity-mask-error 'f 4) exn:fail:contract:arity?)
(err/rt-test (raise-arity-mask-error 'f -8) exn:fail:contract:arity?)
(err/rt-test (raise-arity-mask-error 'f 5) exn:fail:contract:arity?)
(err/rt-test (raise-arity-mask-error 'f -5) exn:fail:contract:arity?)
(err/rt-test (raise-arity-mask-error 'f (arity-at-least 7)) exn:fail:contract:arity?/#f)
(err/rt-test (raise-arity-mask-error 'f -5.0) exn:fail:contract?)
(err/rt-test (raise-arity-mask-error 1 1) exn:fail:contract?)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; continuations
@ -2944,8 +2954,7 @@
not-inc)))
(list proc (procedure-reduce-arity proc ar))))]
[representable-arity? (lambda (a)
(or (not (eq? 'chez-scheme (system-type 'vm)))
(a . < . 4096)))])
(a . < . 4096))])
(let ([check-all-but-one
(lambda (+)
(check-ok + 0 '(0) '(1))

51
pkgs/racket-test-core/tests/racket/object.rktl
View File

@ -1398,57 +1398,6 @@
'(#t #f))
;; ------------------------------------------------------------
;; Check arity reporting for methods.
;; (This is really a Racket test, not a class.rkt test.)
(map
(lambda (jit?)
(parameterize ([eval-jit-enabled jit?])
(let ([mk-f (lambda ()
(eval (syntax-property #'(lambda (a b) a) 'method-arity-error #t)))]
[check-arity-error
(lambda (f cl?)
(test (if cl? '("given: 0") '("expected: 1\n"))
regexp-match #rx"expected: 1\n|given: 0$"
(exn-message (with-handlers ([values values])
;; Use `apply' to avoid triggering
;; compilation of f:
(apply f '(1))))))])
(test 2 procedure-arity (mk-f))
(check-arity-error (mk-f) #f)
(test 1 (mk-f) 1 2)
(let ([f (mk-f)])
(test 1 (mk-f) 1 2)
(check-arity-error (mk-f) #f))
(let ([mk-f (lambda ()
(eval (syntax-property #'(case-lambda [(a b) a][(c d) c]) 'method-arity-error #t)))])
(test 2 procedure-arity (mk-f))
(check-arity-error (mk-f) #t)
(test 1 (mk-f) 1 2)
(let ([f (mk-f)])
(test 1 (mk-f) 1 2)
(check-arity-error (mk-f) #t))))
(let* ([f (lambda (a b) a)]
[meth (procedure->method f)]
[check-arity-error
(lambda (f cl?)
(test (if cl? '("given: 0") '("expected: 1\n"))
regexp-match #rx"expected: 1\n|given: 0$"
(exn-message (with-handlers ([values values])
;; Use `apply' to avoid triggering
;; compilation of f:
(apply f '(1))))))])
(test 2 procedure-arity meth)
(check-arity-error meth #f)
(test 1 meth 1 2)
(let* ([f (case-lambda [(a b) a] [(c d) c])]
[meth (procedure->method f)])
(test 2 procedure-arity meth)
(check-arity-error meth #t)
(test 1 meth 1 2)))))
'(#t #f))
;; ------------------------------------------------------------
;; Check define-member-name, etc.:

89
pkgs/racket-test-core/tests/racket/procs.rktl
View File

@ -132,7 +132,7 @@
err-n)
(exn-message exn))))]))
(let ()
(define (run-procedure-tests procedure-arity procedure-reduce-arity)
(define (get-maybe p n)
(and ((length p) . > . n) (list-ref p n)))
(define (try-combos procs add-chaperone)
@ -361,6 +361,93 @@
(try-combos (map add-chaperone procs) values)
(try-combos (map add-chaperone procs) add-chaperone)))
(define (mask->arity mask)
(let loop ([mask mask] [pos 0])
(cond
[(= mask 0) null]
[(= mask -1) (arity-at-least pos)]
[(bitwise-bit-set? mask 0)
(let ([rest (loop (arithmetic-shift mask -1) (add1 pos))])
(cond
[(null? rest) pos]
[(pair? rest) (cons pos rest)]
[else (list pos rest)]))]
[else
(loop (arithmetic-shift mask -1) (add1 pos))])))
(define (arity->mask a)
(cond
[(exact-nonnegative-integer? a)
(arithmetic-shift 1 a)]
[(arity-at-least? a)
(bitwise-xor -1 (sub1 (arithmetic-shift 1 (arity-at-least-value a))))]
[(list? a)
(let loop ([mask 0] [l a])
(cond
[(null? l) mask]
[else
(let ([a (car l)])
(cond
[(or (exact-nonnegative-integer? a)
(arity-at-least? a))
(loop (bitwise-ior mask (arity->mask a)) (cdr l))]
[else #f]))]))]
[else #f]))
(run-procedure-tests procedure-arity procedure-reduce-arity)
(run-procedure-tests (lambda (p) (mask->arity (procedure-arity-mask p)))
(lambda (p a [name #f]) (procedure-reduce-arity-mask p (arity->mask a) name)))
;; ------------------------------------------------------------
;; Check arity reporting for methods.
(map
(lambda (jit?)
(parameterize ([eval-jit-enabled jit?])
(let ([mk-f (lambda ()
(eval (syntax-property #'(lambda (a b) a) 'method-arity-error #t)))]
[check-arity-error
(lambda (f cl?)
(test (if cl? '("given: 0") '("expected: 1\n"))
regexp-match #rx"expected: 1\n|given: 0$"
(exn-message (with-handlers ([values values])
;; Use `apply' to avoid triggering
;; compilation of f:
(apply f '(1))))))])
(test 2 procedure-arity (mk-f))
(check-arity-error (mk-f) #f)
(test 1 (mk-f) 1 2)
(let ([f (mk-f)])
(test 1 (mk-f) 1 2)
(check-arity-error (mk-f) #f))
(let ([mk-f (lambda ()
(eval (syntax-property #'(case-lambda [(a b) a] [(c d e) c]) 'method-arity-error #t)))])
(test '(2 3) procedure-arity (mk-f))
(check-arity-error (mk-f) #t)
(test 1 (mk-f) 1 2)
(let ([f (mk-f)])
(test 1 (mk-f) 1 2)
(check-arity-error (mk-f) #t))))
(let* ([f (lambda (a b) a)]
[meth (procedure->method f)]
[check-arity-error
(lambda (f cl?)
(test (if cl? '("given: 0") '("expected: 1\n"))
regexp-match #rx"expected: 1\n|given: 0$"
(exn-message (with-handlers ([values values])
;; Use `apply' to avoid triggering
;; compilation of f:
(apply f '(1))))))])
(test 2 procedure-arity meth)
(check-arity-error meth #f)
(test 1 meth 1 2)
(let* ([f (case-lambda [(a b) a] [(c d e) c])]
[meth (procedure->method f)])
(test '(2 3) procedure-arity meth)
(check-arity-error meth #t)
(test 1 meth 1 2)))))
'(#t #f))
;; ----------------------------------------
;; Check error for non-procedures
(err/rt-test (1 2 3) (lambda (x) (regexp-match? "not a procedure" (exn-message x))))

130
racket/collects/racket/private/kw.rkt
View File

@ -27,7 +27,9 @@
keyword-apply
procedure-keywords
new:procedure-reduce-arity
new:procedure-reduce-arity-mask
procedure-reduce-keyword-arity
procedure-reduce-keyword-arity-mask
new-prop:procedure
new:procedure->method
new:procedure-rename
@ -412,7 +414,7 @@
[(proc plain-proc)
(make-optional-keyword-procedure
(make-keyword-checker null #f (and (procedure? proc) ; reundant check helps purity inference
(procedure-arity proc)))
(procedure-arity-mask proc)))
proc
null
#f
@ -1386,20 +1388,13 @@
[else (values #f (car kws))])))
;; Generates a keyword an arity checker dynamically:
(define (make-keyword-checker req-kws allowed-kws arity)
(define (make-keyword-checker req-kws allowed-kws arity-mask)
;; If min-args is #f, then max-args is an arity value.
;; If max-args is #f, then >= min-args is accepted.
(define-syntax (arity-check-lambda stx)
(syntax-case stx ()
[(_ (kws) kw-body)
#'(cond
[(integer? arity)
(lambda (kws a) (and kw-body (= a arity)))]
[(arity-at-least? arity)
(let ([arity (arity-at-least-value arity)])
(lambda (kws a) (and kw-body (a . >= . arity))))]
[else
(lambda (kws a) (and kw-body (arity-includes? arity a)))])]))
#'(lambda (kws a) (and kw-body (bitwise-bit-set? arity-mask a)))]))
(cond
[(not allowed-kws)
;; All allowed
@ -1437,14 +1432,6 @@
;; Required is a subset of allowed
(subsets? req-kws kws allowed-kws)))])]))
(define (arity-includes? arity a)
(cond
[(integer? arity) (= arity a)]
[(arity-at-least? arity)
(a . >= . (arity-at-least-value a))]
[else
(ormap (lambda (ar) (arity-includes? ar a)) arity)]))
(define (subset? l1 l2)
;; l1 and l2 are sorted
(cond
@ -1565,11 +1552,26 @@
(keyword-procedure-extract/method kws n p 0))
;; setting procedure arity
(define (procedure-reduce-keyword-arity proc arity req-kw allowed-kw)
(let* ([plain-proc (procedure-reduce-arity (if (okp? proc)
(define procedure-reduce-keyword-arity
(case-lambda
[(proc arity req-kw allowed-kw name)
(do-procedure-reduce-keyword-arity 'procedure-reduce-keyword-arity proc arity #f name req-kw allowed-kw)]
[(proc arity req-kw allowed-kw)
(do-procedure-reduce-keyword-arity 'procedure-reduce-keyword-arity proc arity #f #f req-kw allowed-kw)]))
(define procedure-reduce-keyword-arity-mask
(case-lambda
[(proc mask req-kw allowed-kw name)
(do-procedure-reduce-keyword-arity 'procedure-reduce-keyword-arity-mask proc #f mask name req-kw allowed-kw)]
[(proc mask req-kw allowed-kw)
(do-procedure-reduce-keyword-arity 'procedure-reduce-keyword-arity-mask proc #f mask #f req-kw allowed-kw)]))
(define (do-procedure-reduce-keyword-arity who proc arity mask name req-kw allowed-kw)
(let* ([plain-proc (let ([p (if (okp? proc)
(okp-ref proc 0)
proc)
arity)])
proc)])
(if arity
(procedure-reduce-arity p arity)
(procedure-reduce-arity-mask p mask name)))])
(define (sorted? kws)
(let loop ([kws kws])
(cond
@ -1580,51 +1582,44 @@
(unless (and (list? req-kw) (andmap keyword? req-kw)
(sorted? req-kw))
(raise-argument-error 'procedure-reduce-keyword-arity "(and/c (listof? keyword?) sorted? distinct?)"
2 proc arity req-kw allowed-kw))
(raise-argument-error who "(and/c (listof? keyword?) sorted? distinct?)"
2 proc (or arity mask) req-kw allowed-kw))
(when allowed-kw
(unless (and (list? allowed-kw) (andmap keyword? allowed-kw)
(sorted? allowed-kw))
(raise-argument-error 'procedure-reduce-keyword-arity "(or/c (and/c (listof? keyword?) sorted? distinct?) #f)"
3 proc arity req-kw allowed-kw))
(raise-argument-error who "(or/c (and/c (listof? keyword?) sorted? distinct?) #f)"
3 proc (or arity mask) req-kw allowed-kw))
(unless (subset? req-kw allowed-kw)
(raise-arguments-error 'procedure-reduce-keyword-arity
(raise-arguments-error who
"allowed-keyword list does not include all required keywords"
"allowed-keyword list" allowed-kw
"required keywords" req-kw)))
(let-values ([(old-req old-allowed) (procedure-keywords proc)])
(unless (subset? old-req req-kw)
(raise-arguments-error 'procedure-reduce-keyword-arity
(raise-arguments-error who
"cannot reduce required keyword set"
"required keywords" old-req
"requested required keywords" req-kw))
(when old-allowed
(unless (subset? req-kw old-allowed)
(raise-arguments-error 'procedure-reduce-keyword-arity
(raise-arguments-error who
"cannot require keywords not in original allowed set"
"original allowed keywords" old-allowed
"requested required keywords" req-kw))
(unless (or (not allowed-kw)
(subset? allowed-kw old-allowed))
(raise-arguments-error 'procedure-reduce-keyword-arity
(raise-arguments-error who
"cannot allow keywords not in original allowed set"
"original allowed keywords" old-allowed
"requested allowed keywords" allowed-kw))))
(if (null? allowed-kw)
plain-proc
(let* ([inc-arity (lambda (arity delta)
(let loop ([a arity])
(cond
[(integer? a) (+ a delta)]
[(arity-at-least? a)
(arity-at-least (+ (arity-at-least-value a) delta))]
[else
(map loop a)])))]
[new-arity (inc-arity arity 2)]
[kw-checker (make-keyword-checker req-kw allowed-kw new-arity)]
(let* ([mask (or mask (arity->mask arity))]
[new-mask (arithmetic-shift mask 2)]
[kw-checker (make-keyword-checker req-kw allowed-kw new-mask)]
[proc (normalize-proc proc)]
[new-kw-proc (procedure-reduce-arity (keyword-procedure-proc proc)
new-arity)])
[new-kw-proc (procedure-reduce-arity-mask (keyword-procedure-proc proc)
new-mask)])
(if (null? req-kw)
;; All keywords are optional:
((if (okm? proc)
@ -1640,9 +1635,9 @@
((make-required (or (and (named-keyword-procedure? proc)
(car (keyword-procedure-name+fail proc)))
(object-name proc))
(procedure-reduce-arity
(procedure-reduce-arity-mask
missing-kw
(inc-arity arity 1))
(arithmetic-shift mask 1))
(or (okm? proc)
(keyword-method? proc))
#f)
@ -1651,9 +1646,29 @@
req-kw
allowed-kw))))))
(define (arity->mask a)
(cond
[(exact-nonnegative-integer? a)
(arithmetic-shift 1 a)]
[(arity-at-least? a)
(bitwise-xor -1 (sub1 (arithmetic-shift 1 (arity-at-least-value a))))]
[(list? a)
(let loop ([mask 0] [l a])
(cond
[(null? l) mask]
[else
(let ([a (car l)])
(cond
[(or (exact-nonnegative-integer? a)
(arity-at-least? a))
(loop (bitwise-ior mask (arity->mask a)) (cdr l))]
[else #f]))]))]
[else #f]))
(define new:procedure-reduce-arity
(let ([procedure-reduce-arity
(lambda (proc arity)
(case-lambda
[(proc arity name)
(if (and (procedure? proc)
(let-values ([(req allows) (procedure-keywords proc)])
(pair? req))
@ -1664,7 +1679,30 @@
(procedure-reduce-arity (if (okm? proc)
(procedure->method proc)
proc)
arity)))])
arity
name))]
[(proc arity)
(new:procedure-reduce-arity proc arity #f)])])
procedure-reduce-arity))
(define new:procedure-reduce-arity-mask
(let ([procedure-reduce-arity
(case-lambda
[(proc mask name)
(if (and (procedure? proc)
(let-values ([(req allows) (procedure-keywords proc)])
(pair? req))
(not (eqv? mask 0)))
(raise-arguments-error 'procedure-reduce-arity
"procedure has required keyword arguments"
"procedure" proc)
(procedure-reduce-arity-mask (if (okm? proc)
(procedure->method proc)
proc)
mask
name))]
[(proc mask)
(new:procedure-reduce-arity-mask proc mask #f)])])
procedure-reduce-arity))
(define new:procedure->method

21
racket/collects/racket/private/norm-arity.rkt
View File

@ -1,25 +1,6 @@
(module norm-arity '#%kernel
(#%require "define.rkt" "small-scheme.rkt" "sort.rkt")
(#%provide norm:procedure-arity
norm:raise-arity-error
normalize-arity) ;; for test suites
(define norm:procedure-arity
(let ([procedure-arity (λ (p) (normalize-arity (procedure-arity p)))])
procedure-arity))
(define norm:raise-arity-error
(let ([raise-arity-error
(λ (name arity-v . arg-vs)
(if (or (exact-nonnegative-integer? arity-v)
(arity-at-least? arity-v)
(and (list? arity-v)
(andmap (λ (x) (or (exact-nonnegative-integer? x)
(arity-at-least? x)))
arity-v)))
(apply raise-arity-error name
(normalize-arity arity-v) arg-vs)
;; here we let raise-arity-error signal an error
(apply raise-arity-error name arity-v arg-vs)))])
raise-arity-error))
(#%provide normalize-arity)
;; normalize-arity : (or/c arity (listof arity))
;; -> (or/c null

7
racket/collects/racket/private/pre-base.rkt
View File

@ -16,7 +16,6 @@
"map.rkt" ; shadows #%kernel bindings
"member.rkt"
"kernstruct.rkt"
"norm-arity.rkt"
"performance-hint.rkt"
"top-int.rkt"
"collect.rkt"
@ -204,9 +203,8 @@
(rename #%module-begin #%plain-module-begin)
(rename printing:module-begin #%printing-module-begin)
(rename module-begin #%module-begin)
(rename norm:procedure-arity procedure-arity)
(rename norm:raise-arity-error raise-arity-error)
(rename new:procedure-reduce-arity procedure-reduce-arity)
(rename new:procedure-reduce-arity-mask procedure-reduce-arity-mask)
(rename new:procedure->method procedure->method)
(rename new:procedure-rename procedure-rename)
(rename new:chaperone-procedure chaperone-procedure)
@ -216,7 +214,7 @@
(rename new:collection-path collection-path)
(rename new:collection-file-path collection-file-path)
(all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure
procedure-arity procedure-reduce-arity raise-arity-error
procedure-reduce-arity procedure-reduce-arity-mask
procedure->method procedure-rename
chaperone-procedure impersonate-procedure
chaperone-procedure* impersonate-procedure*
@ -243,6 +241,7 @@
(rename new-keyword-apply keyword-apply)
procedure-keywords
procedure-reduce-keyword-arity
procedure-reduce-keyword-arity-mask
(rename define-struct* define-struct)
define-struct/derived
struct-field-index

5
racket/src/cs/primitive/kernel.ss
View File

@ -656,12 +656,14 @@
[printf (known-procedure -2)]
[procedure->method (known-procedure 2)]
[procedure-arity (known-procedure 2)]
[procedure-arity-mask (known-procedure 2)]
[procedure-arity-includes? (known-procedure 12)]
[procedure-arity? (known-procedure 2)]
[procedure-closure-contents-eq? (known-procedure 4)]
[procedure-extract-target (known-procedure 2)]
[procedure-impersonator*? (known-procedure 2)]
[procedure-reduce-arity (known-procedure 4)]
[procedure-reduce-arity (known-procedure 12)]
[procedure-reduce-arity-mask (known-procedure 12)]
[procedure-rename (known-procedure 4)]
[procedure-result-arity (known-procedure 2)]
[procedure-specialize (known-procedure 2)]
@ -692,6 +694,7 @@
[raise-argument-error (known-procedure -8)]
[raise-arguments-error (known-procedure -4)]
[raise-arity-error (known-procedure -4)]
[raise-arity-mask-error (known-procedure -4)]
[raise-mismatch-error (known-procedure -8)]
[raise-range-error (known-procedure 384)]
[raise-result-error (known-procedure -8)]

3
racket/src/cs/rumble.sls
View File

@ -139,10 +139,12 @@
extract-procedure ; not exported to Racket
procedure-arity-includes?
procedure-arity
procedure-arity-mask
procedure-result-arity
procedure-extract-target
procedure-closure-contents-eq?
procedure-reduce-arity
procedure-reduce-arity-mask
procedure-rename
procedure->method
procedure-arity?
@ -185,6 +187,7 @@
raise-mismatch-error
raise-range-error
raise-arity-error
raise-arity-mask-error
raise-result-arity-error
raise-type-error
raise-binding-result-arity-error ; not exported to Racket

7
racket/src/cs/rumble/error.ss
View File

@ -329,6 +329,13 @@
" given: " (number->string (length args)))
(current-continuation-marks))))
(define/who (raise-arity-mask-error name mask . args)
(check who (lambda (p) (or (symbol? name) (procedure? name)))
:contract "(or/c symbol? procedure?)"
name)
(check who exact-integer? mask)
(apply raise-arity-error name (mask->arity mask) args))
(define (expected-arity-string arity)
(let ([expected
(lambda (s) (string-append " expected: " s "\n"))])

25
racket/src/cs/rumble/procedure.ss
View File

@ -241,16 +241,37 @@
(define-record reduced-arity-procedure (proc mask name))
(define/who (procedure-reduce-arity proc a)
(define/who procedure-reduce-arity
(case-lambda
[(proc a name)
(check who procedure? proc)
(let ([mask (arity->mask a)])
(unless mask
(raise-arguments-error who "procedure-arity?" a))
(check who symbol? :or-false name)
(unless (= mask (bitwise-and mask (procedure-arity-mask proc)))
(raise-arguments-error who
"arity of procedure does not include requested arity"
"procedure" proc
"requested arity" a))
(do-procedure-reduce-arity-mask proc mask name))]
[(proc a) (procedure-reduce-arity proc a #f)]))
(define/who procedure-reduce-arity-mask
(case-lambda
[(proc mask name)
(check who procedure? proc)
(check who exact-integer? mask)
(check who symbol? :or-false name)
(unless (= mask (bitwise-and mask (procedure-arity-mask proc)))
(raise-arguments-error who
"arity mask of procedure does not include requested arity mask"
"procedure" proc
"requested arity mask" mask))
(do-procedure-reduce-arity-mask proc mask name)]
[(proc mask) (procedure-reduce-arity-mask proc mask #f)]))
(define (do-procedure-reduce-arity-mask proc mask name)
(let ([name (object-name proc)])
(case mask
[(1) (make-arity-wrapper-procedure (if (#%procedure? proc)
@ -283,7 +304,7 @@
args))
(apply proc args))
mask
name)]))))
name)])))
;; ----------------------------------------

6
racket/src/expander/Makefile
View File

@ -22,6 +22,10 @@ KNOT = ++knot read read/api.rkt \
# a direct use of the primitive name:
DIRECT = ++direct linklet ++direct kernel
# Make sure that the flattened form doesn't use
# `make-optional-keyword-procedure`
DISALLOW = ++disallow make-optional-keyword-procedure
# Set `BUILDDIR` as a prefix on "compiled" output (defaults to empty).
# Set `DEPENDSDIR` as the same sort of prefix in the generated
# makefile-dependency file (also defaults to empty). The `BUILDDIR`
@ -31,7 +35,7 @@ DIRECT = ++direct linklet ++direct kernel
expander:
$(RACO) make bootstrap-run.rkt
$(RACKET) bootstrap-run.rkt -c compiled/cache-src $(KNOT) $(DIRECT) --local-rename -O $(TREE)
$(RACKET) bootstrap-run.rkt -c compiled/cache-src $(KNOT) $(DIRECT) $(DISALLOW) --local-rename -O $(TREE)
expander-src:
$(RACO) make bootstrap-run.rkt

41
racket/src/expander/extract/gc-defn.rkt
View File

@ -13,9 +13,13 @@
(provide garbage-collect-definitions)
(define (garbage-collect-definitions linklet-expr)
(define (garbage-collect-definitions linklet-expr
#:disallows disallows)
(log-status "Removing unused definitions...")
(define disallow-ht (for/hasheq ([s (in-list disallows)])
(values s #t)))
(define body (bootstrap:s-expr-linklet-body linklet-expr))
(define used-syms (make-hasheq))
@ -33,12 +37,34 @@
(for ([sym (in-list (defn-syms e))])
(hash-set! sym-to-rhs sym (defn-rhs e)))]))
;; To track dependencies for reporting
(define use-deps (make-hasheq))
(define (track-and-check-disallowed! sym used-by)
(when (hash-ref disallow-ht sym #f)
(apply raise-arguments-error
'flatten "disallowed identifier's definition preserved"
"identifier" sym
(let loop ([used-by used-by])
(cond
[(not used-by) null]
[else
(or (and (list? used-by)
(for/or ([used-by (in-list used-by)])
(define next (hash-ref use-deps used-by #f))
(and next
(list* "due to" used-by
(loop next)))))
(list* "due to" used-by
(loop (hash-ref use-deps used-by #f))))]))))
(hash-set! use-deps sym used-by))
;; A "mark"-like traversal of an expression:
(define (set-all-used! e)
(define (set-all-used! e used-by)
(for ([sym (in-set (all-used-symbols e))])
(unless (hash-ref used-syms sym #f)
(hash-set! used-syms sym #t)
(set-all-used! (hash-ref sym-to-rhs sym #f)))))
(track-and-check-disallowed! sym used-by)
(set-all-used! (hash-ref sym-to-rhs sym #f) sym))))
;; Helper to check for side-effects at a definition
(define (defn-side-effects? e)
@ -59,8 +85,9 @@
;; definition and mark everything as used:
(for ([sym (in-list (defn-syms defn))])
(unless (hash-ref used-syms sym #f)
(track-and-check-disallowed! sym '#:rhs-effect)
(hash-set! used-syms sym #t)))
(set-all-used! (defn-rhs defn))
(set-all-used! (defn-rhs defn) (defn-syms defn))
;; Afterward, these identifiers are defined.
;; (It's ok if delayed types refer to these,
;; because they're apparently used later if they're
@ -68,7 +95,7 @@
(for ([sym (in-list (defn-syms defn))])
(hash-set! seen-defns sym (known-defined)))]
[else
;; The definition itself doesn't have a side effect, so dont
;; The definition itself doesn't have a side effect, so don't
;; mark it as used right away, and delay analysis to make it
;; independent of order within a group without side effects
(define thunk
@ -83,12 +110,12 @@
(hash-set! seen-defns sym thunk))])
(loop (cdr body))]
[else
(set-all-used! (car body))
(set-all-used! (car body) '#:effect)
(loop (cdr body))]))
;; Mark each export:
(for ([ex+sym (in-list (bootstrap:s-expr-linklet-exports+locals linklet-expr))])
(set-all-used! (cdr ex+sym)))
(set-all-used! (cdr ex+sym) '#:export))
(define can-remove-count
(for/sum ([e (in-list body)])

3
racket/src/expander/extract/known-primitive.rkt
View File

@ -21,4 +21,5 @@
(hash-set! seen-defns 'arity-at-least? (known-predicate 'arity-at-least))
(hash-set! seen-defns 'arity-at-least-value (known-function-of-satisfying '(arity-at-least)))
(hash-set! seen-defns 'procedure? (known-predicate 'procedure))
(hash-set! seen-defns 'procedure-arity (known-function-of-satisfying '(procedure))))
(hash-set! seen-defns 'procedure-arity (known-function-of-satisfying '(procedure)))
(hash-set! seen-defns 'procedure-arity-mask (known-function-of-satisfying '(procedure))))

8
racket/src/expander/extract/main.rkt
View File

@ -44,7 +44,10 @@
;; Override linklet compiler's simple inference
;; of side-effects to remove a module from the
;; flattened form if it's not otherwise referenced:
#:side-effect-free-modules side-effect-free-modules)
#:side-effect-free-modules side-effect-free-modules
;; A list of symbols that should not be defined in the
;; flattened, GCed form:
#:disallows disallows)
;; Located modules:
(define compiled-modules (make-hash))
@ -134,7 +137,8 @@
;; Remove unreferenced definitions
(define gced-linklet-expr
(garbage-collect-definitions simplified-expr))
(garbage-collect-definitions simplified-expr
#:disallows disallows))
(log-status "Checking that references outside the runtime were removed by simplification...")
(define really-used-names (all-used-symbols gced-linklet-expr))

6
racket/src/expander/run.rkt
View File

@ -50,6 +50,7 @@
(define instance-knot-ties (make-hasheq))
(define primitive-table-directs (make-hasheq))
(define side-effect-free-modules (make-hash))
(define disallows null)
(define quiet-load? #f)
(define startup-module main.rkt)
(define submod-name #f)
@ -101,6 +102,8 @@
(hash-set! dependencies (simplify-path (path->complete-path file)) #t)]
[("++depend-module") mod-file "Add <mod-file> and transitive as dependencies"
(set! extra-module-dependencies (cons mod-file extra-module-dependencies))]
[("++disallow") id "If <id> is defined in the flattened version, explain why"
(set! disallows (cons (string->symbol id) disallows))]
#:once-each
[("--local-rename") "Use simpler names in extracted, instead of a unique name for each binding"
(set! local-rename? #t)]
@ -320,7 +323,8 @@
#:local-rename? local-rename?
#:instance-knot-ties instance-knot-ties
#:primitive-table-directs primitive-table-directs
#:side-effect-free-modules side-effect-free-modules))
#:side-effect-free-modules side-effect-free-modules
#:disallows disallows))
(when load-file
(load load-file))

43
racket/src/racket/src/error.c
View File

@ -105,6 +105,7 @@ static Scheme_Object *raise_mismatch_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_arguments_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_range_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_arity_mask_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *raise_result_arity_error(int argc, Scheme_Object *argv[]);
static Scheme_Object *error_escape_handler(int, Scheme_Object *[]);
static Scheme_Object *error_display_handler(int, Scheme_Object *[]);
@ -817,6 +818,7 @@ void scheme_init_error(Scheme_Startup_Env *env)
scheme_raise_arity_error_proc = scheme_make_noncm_prim(raise_arity_error, "raise-arity-error", 2, -1);
scheme_addto_prim_instance("raise-arity-error", scheme_raise_arity_error_proc, env);
ESCAPING_NONCM_PRIM("raise-arity-mask-error", raise_arity_mask_error, 2, -1, env);
ESCAPING_NONCM_PRIM("raise-result-arity-error", raise_result_arity_error, 2, -1, env);
ADD_PARAMETER("error-display-handler", error_display_handler, MZCONFIG_ERROR_DISPLAY_HANDLER, env);
@ -2970,20 +2972,29 @@ static int is_arity_list(Scheme_Object *l)
return 1;
}
static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[])
static Scheme_Object *do_raise_arity_error(const char *who, int argc, Scheme_Object *argv[], int as_arity)
{
Scheme_Object **args;
Scheme_Object **args, *arity;
const char *name;
int minc, maxc;
if (!SCHEME_SYMBOLP(argv[0]) && !SCHEME_PROCP(argv[0]))
scheme_wrong_contract("raise-arity-error", "(or/c symbol? procedure?)", 0, argc, argv);
if (!scheme_nonneg_exact_p(argv[1])
&& !is_arity_at_least(argv[1])
&& !is_arity_list(argv[1]))
scheme_wrong_contract("raise-arity-error",
scheme_wrong_contract(who, "(or/c symbol? procedure?)", 0, argc, argv);
if (as_arity) {
arity = argv[1];
if (!scheme_nonneg_exact_p(arity)
&& !is_arity_at_least(arity)
&& !is_arity_list(arity))
scheme_wrong_contract(who,
"(or/c exact-nonnegative-integer? arity-at-least? (listof (or/c exact-nonnegative-integer? arity-at-least?)))",
1, argc, argv);
} else {
if (!scheme_exact_p(argv[1]))
scheme_wrong_contract(who,
"exact-integer?",
1, argc, argv);
arity = scheme_arity_mask_to_arity(argv[1], -1);
}
args = MALLOC_N(Scheme_Object*, argc - 2);
memcpy(args, argv + 2, sizeof(Scheme_Object*) * (argc - 2));
@ -2995,11 +3006,11 @@ static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[])
name = scheme_get_proc_name(argv[0], &len, 1);
}
if (SCHEME_INTP(argv[1])) {
minc = maxc = SCHEME_INT_VAL(argv[1]);
} else if (is_arity_at_least(argv[1])) {
if (SCHEME_INTP(arity)) {
minc = maxc = SCHEME_INT_VAL(arity);
} else if (is_arity_at_least(arity)) {
Scheme_Object *v;
v = scheme_struct_ref(argv[1], 0);
v = scheme_struct_ref(arity, 0);
if (SCHEME_INTP(v)) {
minc = SCHEME_INT_VAL(v);
maxc = -1;
@ -3017,6 +3028,16 @@ static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[])
return NULL;
}
static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[])
{
return do_raise_arity_error("raise-arity-error", argc, argv, 1);
}
static Scheme_Object *raise_arity_mask_error(int argc, Scheme_Object *argv[])
{
return do_raise_arity_error("raise-arity-mask-error", argc, argv, 0);
}
static Scheme_Object *raise_result_arity_error(int argc, Scheme_Object *argv[])
{
const char *where = NULL, *detail = NULL;

426
racket/src/racket/src/fun.c
View File

@ -146,7 +146,9 @@ static Scheme_Object *seconds_to_date(int argc, Scheme_Object **argv);
static Scheme_Object *object_name(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_arity_mask(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_reduce_arity_mask(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]);
@ -193,6 +195,8 @@ typedef void (*DW_PrePost_Proc)(void *);
#define CONS(a,b) scheme_make_pair(a,b)
static Scheme_Object *mask_to_arity(Scheme_Object *mask, int mode);
#ifdef MZ_PRECISE_GC
static void register_traversers(void);
#endif
@ -543,16 +547,27 @@ scheme_init_fun (Scheme_Startup_Env *env)
scheme_procedure_arity_includes_proc = o;
scheme_addto_prim_instance("procedure-arity-includes?", o, env);
scheme_addto_prim_instance("procedure-arity-mask",
scheme_make_folding_prim(procedure_arity_mask,
"procedure-arity-mask",
1, 1, 1),
env);
scheme_addto_prim_instance("procedure-reduce-arity",
scheme_make_prim_w_arity(procedure_reduce_arity,
"procedure-reduce-arity",
2, 2),
2, 3),
env);
scheme_addto_prim_instance("procedure-rename",
scheme_make_prim_w_arity(procedure_rename,
"procedure-rename",
2, 2),
env);
scheme_addto_prim_instance("procedure-reduce-arity-mask",
scheme_make_prim_w_arity(procedure_reduce_arity_mask,
"procedure-reduce-arity-mask",
2, 3),
env);
scheme_addto_prim_instance("procedure->method",
scheme_make_prim_w_arity(procedure_to_method,
"procedure->method",
@ -1688,7 +1703,7 @@ _scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
/* arity */
/*========================================================================*/
static Scheme_Object *make_arity(mzshort mina, mzshort maxa, int mode)
static Scheme_Object *make_arity(intptr_t mina, intptr_t maxa, int mode)
{
if (mina == maxa)
return scheme_make_integer(mina);
@ -1701,7 +1716,7 @@ static Scheme_Object *make_arity(mzshort mina, mzshort maxa, int mode)
return scheme_make_struct_instance(scheme_arity_at_least, 1, p);
}
} else {
int i;
intptr_t i;
Scheme_Object *l = scheme_null;
for (i = maxa; i >= mina; --i) {
@ -1717,33 +1732,52 @@ Scheme_Object *scheme_make_arity(mzshort mina, mzshort maxa)
return make_arity(mina, maxa, -1);
}
static Scheme_Object *clone_arity(Scheme_Object *a, int delta, int mode)
Scheme_Object *shift_for_drop(Scheme_Object *n, int drop)
{
if (SCHEME_PAIRP(a)) {
Scheme_Object *m, *l;
m = scheme_copy_list(a);
for (l = m; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = clone_arity(SCHEME_CAR(l), delta, mode);
SCHEME_CAR(l) = a;
Scheme_Object *a[2];
a[0] = n;
a[1] = scheme_make_integer(-drop);
return scheme_bitwise_shift(2, a);
}
return m;
} else if (SCHEME_CHAPERONE_STRUCTP(a)) {
Scheme_Object *p[1];
a = scheme_struct_ref(a, 0);
if (delta)
a = scheme_bin_minus(a, scheme_make_integer(delta));
if (mode == -3) {
return scheme_make_integer(-(SCHEME_INT_VAL(a)+1));
} else {
p[0] = a;
return scheme_make_struct_instance(scheme_arity_at_least, 1, p);
static Scheme_Object *make_shifted_one(intptr_t n)
{
Scheme_Object *a[2];
a[0] = scheme_make_integer(1);
a[1] = scheme_make_integer(n);
return scheme_bitwise_shift(2, a);
}
} else if (SCHEME_NULLP(a))
return a;
else if (delta)
return scheme_bin_minus(a, scheme_make_integer(delta));
static Scheme_Object *make_arity_mask(intptr_t mina, intptr_t maxa)
{
/* Generate a mask */
if (mina == maxa) {
if (mina < SCHEME_MAX_FAST_ARITY_CHECK)
return scheme_make_integer(1 << mina);
else
return a;
return make_shifted_one(mina);
} else if (maxa == -1) {
if (mina < SCHEME_MAX_FAST_ARITY_CHECK) {
return scheme_make_integer(((1 << mina) - 1) ^ (intptr_t)-1);
} else {
return scheme_bin_bitwise_xor(scheme_bin_minus(make_shifted_one(mina), scheme_make_integer(1)),
scheme_make_integer(-1));
}
} else {
mzshort i;
Scheme_Object *mask = scheme_make_integer(0);
for (i = mina; i <= maxa; i++) {
mask = scheme_bin_bitwise_or(make_shifted_one(i), mask);
}
return mask;
}
}
Scheme_Object *scheme_make_arity_mask(intptr_t mina, intptr_t maxa)
{
return make_arity_mask(mina, maxa);
}
int scheme_fast_check_arity(Scheme_Object *p, int a)
@ -1780,7 +1814,8 @@ int scheme_fast_check_arity(Scheme_Object *p, int a)
static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Object *bign, int inc_ok)
/* a == -1 => get arity
a == -2 => check for allowing bignum
a == -3 => like -1, but alternate representation using negative numbers for arity-at-least */
a == -3 => like -1, but alternate representation using negative numbers for arity-at-least
a == -4 => mask */
{
Scheme_Type type;
mzshort mina, maxa;
@ -1815,16 +1850,14 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
Scheme_Case_Lambda *seq;
Scheme_Lambda *data;
int i;
Scheme_Object *first, *last = NULL, *v;
if ((a == -1) || (a == -3))
first = scheme_null;
else
first = scheme_false;
Scheme_Object *mask = scheme_make_integer(0), *v;
seq = (Scheme_Case_Lambda *)p;
for (i = 0; i < seq->count; i++) {
v = seq->array[i];
if ((a == -1) || (a == -3) || (a == -4)) {
mask = scheme_bin_bitwise_or(get_or_check_arity(v, -4, NULL, inc_ok), mask);
} else {
if (SAME_TYPE(SCHEME_TYPE(v), scheme_lambda_type))
data = (Scheme_Lambda *)v;
else
@ -1842,74 +1875,61 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
} else if (a == -2) {
if (maxa < 0)
return scheme_true;
} else {
if (mina >= drop) {
mina -= drop;
if (maxa > 0)
maxa -= drop;
}
}
}
v = scheme_make_pair(make_arity(mina, maxa, a), scheme_null);
if (!last)
first = v;
if ((a == -1) || (a == -3) || (a == -4)) {
if (drop && (a == -4))
mask = shift_for_drop(mask, drop);
if (a != -4)
return mask_to_arity(mask, a);
else
SCHEME_CDR(last) = v;
last = v;
}
}
}
return first;
return mask;
} else
return scheme_false;
} else if (type == scheme_proc_struct_type) {
int is_method;
if (!inc_ok
&& scheme_no_arity_property
&& scheme_struct_type_property_ref(scheme_no_arity_property, p))
&& scheme_struct_type_property_ref(scheme_no_arity_property, p)) {
if (a == -4)
return scheme_make_integer(0);
else
return scheme_false;
}
if (scheme_reduced_procedure_struct
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, p)) {
if (a == -4) {
p = ((Scheme_Structure *)p)->slots[1];
if (drop)
return shift_for_drop(p, drop);
else
return p;
}
if (a >= 0) {
bign = scheme_make_integer(a);
if (drop)
bign = scheme_bin_plus(bign, scheme_make_integer(drop));
}
if ((a == -1) || (a == -3))
return clone_arity(((Scheme_Structure *)p)->slots[1], drop, a);
else {
/* Check arity (or for varargs) */
Scheme_Object *v;
v = ((Scheme_Structure *)p)->slots[1];
if (SCHEME_STRUCTP(v)) {
v = ((Scheme_Structure *)v)->slots[0];
return (scheme_bin_lt_eq(v, bign)
? scheme_true
: scheme_false);
} else if (SCHEME_PAIRP(v)) {
Scheme_Object *x;
while (!SCHEME_NULLP(v)) {
x = SCHEME_CAR(v);
if (SCHEME_STRUCTP(x)) {
x = ((Scheme_Structure *)x)->slots[0];
if (scheme_bin_lt_eq(x, bign))
return scheme_true;
if ((a == -1) || (a == -3)) {
p = ((Scheme_Structure *)p)->slots[1];
if (drop)
p = shift_for_drop(p, drop);
return mask_to_arity(p, a);
} else {
if (scheme_bin_eq(x, bign))
if (scheme_bin_bitwise_bit_set_p(((Scheme_Structure *)p)->slots[1], bign))
return scheme_true;
}
v = SCHEME_CDR(v);
}
else
return scheme_false;
} else if (SCHEME_NULLP(v)) {
return scheme_false;
} else {
return (scheme_bin_eq(v, bign)
? scheme_true
: scheme_false);
}
}
} else {
p = scheme_extract_struct_procedure(p, -1, NULL, &is_method);
if (!SCHEME_PROCP(p)) {
if ((a == -1) || (a == -3))
if (a == -4)
return scheme_make_integer(0);
else if ((a == -1) || (a == -3))
return scheme_null;
else
return scheme_false;
@ -1925,6 +1945,12 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
Scheme_Object *pa;
pa = scheme_get_native_arity(p, a);
if (a == -4) {
if (drop)
return shift_for_drop(pa, drop);
else
return pa;
}
if (SCHEME_BOXP(pa)) {
/* Is a method; pa already corrects for it */
@ -2040,40 +2066,21 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
if (cases) {
int count = cases_count, i;
if ((a == -1) || (a == -3) || (a == -4)) {
/* Compute mask to get arity so that the arity is normalized */
Scheme_Object *mask = scheme_make_integer(0);
if ((a == -1) || (a == -3)) {
Scheme_Object *arity, *ae, *last = NULL;
arity = scheme_alloc_list(count);
for (i = 0, ae = arity; i < count; i++) {
Scheme_Object *av;
int mn, mx;
mn = cases[2 * i];
mx = cases[(2 * i) + 1];
if (mn >= drop) {
mn -= drop;
if (mx > 0)
mx -= drop;
av = make_arity(mn, mx, a);
SCHEME_CAR(ae) = av;
last = ae;
ae = SCHEME_CDR(ae);
}
for (i = 0; i < count; i++) {
mask = scheme_bin_bitwise_or(make_arity_mask(cases[2 * i], cases[(2 * i)+1]), mask);
}
if (drop)
mask = shift_for_drop(mask, drop);
/* If drop > 0, might have found no matches */
if (!SCHEME_NULLP(ae)) {
if (last)
SCHEME_CDR(last) = scheme_null;
if (a == -4)
return mask;
else
arity = scheme_null;
}
return arity;
return mask_to_arity(mask, a);
}
if (a == -2) {
@ -2098,11 +2105,14 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
return scheme_false;
}
if ((a == -1) || (a == -3)) {
if ((a == -1) || (a == -3) || (a == -4)) {
if (mina < drop) {
if ((maxa >= 0) && (maxa < drop))
return scheme_null;
if ((maxa >= 0) && (maxa < drop)) {
if (a == -4)
return scheme_make_integer(0);
else
return scheme_null;
} else
mina = 0;
} else
mina -= drop;
@ -2111,6 +2121,9 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
maxa -= drop;
}
if (a == -4)
return make_arity_mask(mina, maxa);
return make_arity(mina, maxa, a);
}
@ -2130,6 +2143,11 @@ Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, intptr_t a)
return get_or_check_arity(p, a, NULL, 1);
}
Scheme_Object *scheme_get_arity_mask(Scheme_Object *p)
{
return get_or_check_arity(p, -4, NULL, 1);
}
int scheme_check_proc_arity2(const char *where, int a,
int which, int argc, Scheme_Object **argv,
int false_ok)
@ -2714,6 +2732,14 @@ static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[])
return get_or_check_arity(argv[0], -1, NULL, 1);
}
static Scheme_Object *procedure_arity_mask(int argc, Scheme_Object *argv[])
{
if (!SCHEME_PROCP(argv[0]))
scheme_wrong_contract("procedure-arity-mask", "procedure?", 0, argc, argv);
return get_or_check_arity(argv[0], -4, NULL, 1);
}
static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[])
{
Scheme_Object *a = argv[0], *v;
@ -2803,7 +2829,7 @@ void scheme_init_reduced_proc_struct(Scheme_Startup_Env *env)
scheme_reduced_procedure_struct = scheme_make_struct_type2(NULL,
NULL,
(Scheme_Object *)insp,
5, 0,
4, 0,
scheme_false,
scheme_null,
scheme_make_integer(0),
@ -2811,49 +2837,99 @@ void scheme_init_reduced_proc_struct(Scheme_Startup_Env *env)
}
}
static Scheme_Object *arity_to_fast_check_mask(Scheme_Object *aty)
static Scheme_Object *arity_to_mask(Scheme_Object *aty)
{
if (SCHEME_INTP(aty)) {
intptr_t n = SCHEME_INT_VAL(aty);
if (n <= SCHEME_MAX_FAST_ARITY_CHECK)
return scheme_make_integer(1 << n);
else
return scheme_make_integer(0);
return make_shifted_one(n);
} else if (SCHEME_BIGNUMP(aty)) {
scheme_raise_out_of_memory(NULL, NULL);
return NULL;
} else if (SCHEME_STRUCTP(aty)) {
Scheme_Object *mask;
intptr_t n;
mask = arity_to_fast_check_mask(scheme_struct_ref(aty, 0));
n = SCHEME_INTP(mask);
if (!n)
return mask;
aty = scheme_struct_ref(aty, 0);
if (SCHEME_INTP(aty))
return make_arity_mask(SCHEME_INT_VAL(aty), -1);
else {
/* Set all bits above highest-set bit */
int i;
for (i = SCHEME_MAX_FAST_ARITY_CHECK; ; i--) {
if (n & (1 << i))
break;
n |= (1 << i);
}
return scheme_make_integer(n);
mask = arity_to_mask(aty);
return scheme_bin_bitwise_xor(scheme_bin_minus(mask, scheme_make_integer(1)),
scheme_make_integer(-1));
}
} else if (SCHEME_PAIRP(aty)) {
Scheme_Object *mask;
intptr_t n = 0;
Scheme_Object *mask = scheme_make_integer(0);
while (SCHEME_PAIRP(aty)) {
mask = arity_to_fast_check_mask(SCHEME_CAR(aty));
n |= SCHEME_INT_VAL(mask);
mask = scheme_bin_bitwise_or(arity_to_mask(SCHEME_CAR(aty)), mask);
aty = SCHEME_CDR(aty);
}
return scheme_make_integer(n);
return mask;
} else
return scheme_make_integer(0);
}
static Scheme_Object *make_reduced_proc(Scheme_Object *proc, Scheme_Object *aty, Scheme_Object *name, Scheme_Object *is_meth)
static Scheme_Object *mask_to_arity(Scheme_Object *mask, int mode)
{
intptr_t n, pos = 0;
Scheme_Object *l = scheme_null;
while (!SCHEME_INTP(mask)) {
Scheme_Object *a[2], *b;
b = scheme_bin_bitwise_and(mask, scheme_make_integer(0xFFFF));
if (SCHEME_INTP(b)) {
b = scheme_bin_bitwise_and(mask, scheme_make_integer(1));
if (SCHEME_INTP(b))
l = scheme_make_pair(scheme_make_integer(pos), l);
pos++;
a[0] = mask;
a[1] = scheme_make_integer(-1);
mask = scheme_bitwise_shift(2, a);
} else {
pos += 16;
a[0] = mask;
a[1] = scheme_make_integer(-16);
mask = scheme_bitwise_shift(2, a);
}
}
n = SCHEME_INT_VAL(mask);
if (!n) {
if (SCHEME_PAIRP(l) && SCHEME_NULLP(SCHEME_CDR(l)))
return SCHEME_CAR(l);
else
return scheme_reverse(l);
}
while (1) {
if (n == -1) {
if (SCHEME_NULLP(l))
return make_arity(pos, -1, mode);
else
return scheme_reverse(scheme_make_pair(make_arity(pos, -1, mode), l));
} else if (n == 1) {
if (SCHEME_NULLP(l))
return scheme_make_integer(pos);
else
return scheme_reverse(scheme_make_pair(scheme_make_integer(pos), l));
} else if (n & 0x1) {
l = scheme_make_pair(scheme_make_integer(pos), l);
}
pos++;
n >>= 1;
}
}
Scheme_Object *scheme_arity_mask_to_arity(Scheme_Object *mask, int mode)
{
return mask_to_arity(mask, mode);
}
static Scheme_Object *make_reduced_proc(Scheme_Object *proc,
Scheme_Object *mask,
Scheme_Object *name, Scheme_Object *is_meth)
{
Scheme_Object *mask;
Scheme_Structure *inst;
if (SCHEME_STRUCTP(proc)
@ -2866,20 +2942,15 @@ static Scheme_Object *make_reduced_proc(Scheme_Object *proc, Scheme_Object *aty,
proc = ((Scheme_Structure *)proc)->slots[0];
}
/* A fast-check bitmap, where a bitmap is set in a fixnum if that
many arguments are allowed: */
mask = arity_to_fast_check_mask(aty);
inst = (Scheme_Structure *)scheme_malloc_tagged(sizeof(Scheme_Structure)
+ ((5 - mzFLEX_DELTA) * sizeof(Scheme_Object *)));
+ ((4 - mzFLEX_DELTA) * sizeof(Scheme_Object *)));
inst->so.type = scheme_proc_struct_type;
inst->stype = (Scheme_Struct_Type *)scheme_reduced_procedure_struct;
inst->slots[0] = proc;
inst->slots[1] = aty;
inst->slots[1] = mask;
inst->slots[2] = (name ? name : scheme_false);
inst->slots[3] = (is_meth ? is_meth : scheme_false);
inst->slots[4] = mask;
return (Scheme_Object *)inst;
}
@ -3049,31 +3120,50 @@ static int proc_is_method(Scheme_Object *proc)
return 0;
}
static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
static Scheme_Object *do_procedure_reduce_arity(const char *who, int argc, Scheme_Object *argv[], int as_arity)
{
Scheme_Object *orig, *aty, *is_meth = NULL;
Scheme_Object *orig, *mask, *is_meth = NULL, *name = NULL;
if (!SCHEME_PROCP(argv[0]))
scheme_wrong_contract("procedure-reduce-arity", "procedure?", 0, argc, argv);
if (as_arity) {
if (!is_arity(argv[1], 1, 1)) {
scheme_wrong_contract("procedure-reduce-arity",
scheme_wrong_contract(who,
"(or/c exact-nonnegative-integer? arity-at-least? (listof (or/c exact-nonnegative-integer? arity-at-least?)))",
1, argc, argv);
}
mask = arity_to_mask(argv[1]);
} else {
mask = argv[1];
if (!scheme_exact_p(mask)) {
scheme_wrong_contract(who, "exact-integer?", 1, argc, argv);
return NULL;
}
}
/* Check whether current arity covers the requested arity. This is
a bit complicated, because both the source and target can be
lists that include arity-at-least records. */
if (argc > 2) {
name = argv[2];
if (SCHEME_FALSEP(name))
name = NULL;
else if (!SCHEME_SYMBOLP(name)) {
scheme_wrong_contract(who, "(or/c symbol? #f)", 2, argc, argv);
return NULL;
}
} else
name = NULL;
orig = get_or_check_arity(argv[0], -1, NULL, 1);
aty = clone_arity(argv[1], 0, -1);
/* Check whether current arity covers the requested arity. */
if (!is_subarity(aty, orig, 0)) {
scheme_contract_error("procedure-reduce-arity",
"arity of procedure does not include requested arity",
orig = get_or_check_arity(argv[0], -4, NULL, 1);
if (!scheme_bin_eq(scheme_bin_bitwise_and(mask, orig), mask)) {
scheme_contract_error(who,
(as_arity
? "arity of procedure does not include requested arity"
: "arity mask of procedure does not include requested arity mask"),
"procedure", 1, argv[0],
"requested arity", 1, argv[1],
(as_arity ? "requested arity" : "requested arity mask"), 1, argv[1],
NULL);
return NULL;
}
@ -3082,12 +3172,22 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
is_meth = scheme_true;
/* Construct a procedure that has the given arity. */
return make_reduced_proc(argv[0], aty, NULL, is_meth);
return make_reduced_proc(argv[0], mask, name, is_meth);
}
static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
{
return do_procedure_reduce_arity("procedure-reduce-arity", argc, argv, 1);
}
static Scheme_Object *procedure_reduce_arity_mask(int argc, Scheme_Object *argv[])
{
return do_procedure_reduce_arity("procedure-reduce-arity-mask", argc, argv, 0);
}
static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[])
{
Scheme_Object *p, *aty;
Scheme_Object *p, *mask;
if (!SCHEME_PROCP(argv[0]))
scheme_wrong_contract("procedure-rename", "procedure?", 0, argc, argv);
@ -3097,21 +3197,21 @@ static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[])
p = scheme_rename_struct_proc(argv[0], argv[1]);
if (p) return p;
aty = get_or_check_arity(argv[0], -1, NULL, 1);
mask = get_or_check_arity(argv[0], -4, NULL, 1);
return make_reduced_proc(argv[0], aty, argv[1], NULL);
return make_reduced_proc(argv[0], mask, argv[1], NULL);
}
static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[])
{
Scheme_Object *aty;
Scheme_Object *mask;
if (!SCHEME_PROCP(argv[0]))
scheme_wrong_contract("procedure->method", "procedure?", 0, argc, argv);
aty = get_or_check_arity(argv[0], -1, NULL, 1);
mask = get_or_check_arity(argv[0], -4, NULL, 1);
return make_reduced_proc(argv[0], aty, NULL, scheme_true);
return make_reduced_proc(argv[0], mask, NULL, scheme_true);
}
static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[])

39
racket/src/racket/src/jit.c
View File

@ -4474,8 +4474,8 @@ Scheme_Object *scheme_get_native_arity(Scheme_Object *closure, int mode)
cnt = ((Scheme_Native_Closure *)closure)->code->closure_size;
if (cnt < 0) {
/* Case-lambda */
Scheme_Object *l = scheme_null, *a;
int i, has_rest, is_method;
Scheme_Object *l = scheme_make_integer(0);
int i, is_method;
mzshort *arities, v;
arities = ((Scheme_Native_Closure *)closure)->code->u.arities;
@ -4483,20 +4483,16 @@ Scheme_Object *scheme_get_native_arity(Scheme_Object *closure, int mode)
is_method = arities[cnt];
for (i = cnt; i--; ) {
v = arities[i];
if (v < 0) {
v = -(v + 1);
has_rest = 1;
} else
has_rest = 0;
if (mode == -3) {
if (has_rest) v = -(v+1);
a = scheme_make_integer(v);
} else
a = scheme_make_arity(v, has_rest ? -1 : v);
l = scheme_make_pair(a, l);
if (v < 0)
l = scheme_bin_bitwise_or(scheme_make_arity_mask(-(v+1), -1), l);
else
l = scheme_bin_bitwise_or(scheme_make_arity_mask(v, v), l);
}
if (mode != -4) {
l = scheme_arity_mask_to_arity(l, mode);
if (is_method)
l = scheme_box(l);
}
return l;
}
@ -4505,12 +4501,29 @@ Scheme_Object *scheme_get_native_arity(Scheme_Object *closure, int mode)
Scheme_Object *a;
c.so.type = scheme_closure_type;
c.code = ((Scheme_Native_Closure *)closure)->code->u2.orig_code;
if (mode == -4) {
return scheme_get_arity_mask((Scheme_Object *)&c);
} else {
a = scheme_get_or_check_arity((Scheme_Object *)&c, -1);
if (SCHEME_LAMBDA_FLAGS(c.code) & LAMBDA_IS_METHOD)
a = scheme_box(a);
return a;
}
}
if (mode == -4) {
Scheme_Object *a;
intptr_t n;
a = sjc.get_arity_code(closure, 0, 0 EXTRA_NATIVE_ARGUMENT);
if (SCHEME_BOXP(a)) a = SCHEME_BOX_VAL(a);
n = SCHEME_INT_VAL(a);
if (n < 0)
return scheme_make_arity_mask(-(n+1), -1);
else if (n < SCHEME_MAX_FAST_ARITY_CHECK)
return scheme_make_integer(1 << n);
else
return scheme_make_arity_mask(n, n);
} else
return sjc.get_arity_code(closure, 0, 0 EXTRA_NATIVE_ARGUMENT);
}

8
racket/src/racket/src/jitcall.c
View File

@ -70,7 +70,7 @@ static Scheme_Object *clear_runstack(Scheme_Object **rs, intptr_t amt, Scheme_Ob
static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands, GC_CAN_IGNORE jit_insn *refagain)
{
GC_CAN_IGNORE jit_insn *ref2, *ref3, *refz1, *refz2, *refz3, *refz4, *refz5;
GC_CAN_IGNORE jit_insn *ref2, *ref3, *refz1, *refz2, *refz3, *refy3, *refz4, *refz5;
GC_CAN_IGNORE jit_insn *refz6, *refz7, *refz8, *refz9, *ref9, *ref10;
ref2 = jit_bnei_i(jit_forward(), JIT_R1, scheme_proc_struct_type);
@ -83,7 +83,8 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
ref3 = jit_bner_p(jit_forward(), JIT_R1, JIT_R2);
/* Matches reduced arity in a simple way? */
jit_ldxi_p(JIT_R2, JIT_V1, &((Scheme_Structure *)0x0)->slots[4]);
jit_ldxi_p(JIT_R2, JIT_V1, &((Scheme_Structure *)0x0)->slots[1]);
refy3 = jit_bmci_l(jit_forward(), JIT_R2, 1); /* not a fixnum? */
refz3 = jit_bmci_l(jit_forward(), JIT_R2, (1 << (num_rands + 1)));
/* Yes, matches */
@ -91,6 +92,7 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
} else {
/* Too many arguments for fast check, so assume it desn't match */
refz3 = jit_beqr_p(jit_forward(), JIT_R1, JIT_R2);
refy3 = NULL;
}
/* It's an applicable struct that is not an arity reduce or the
@ -176,6 +178,8 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
mz_patch_branch(refz1);
mz_patch_branch(refz2);
mz_patch_branch(refz3);
if (refy3)
mz_patch_branch(refy3);
mz_patch_branch(refz4);
mz_patch_branch(refz5);
mz_patch_branch(refz6);

31
racket/src/racket/src/number.c
View File

@ -4229,6 +4229,21 @@ GEN_BIN_INT_OP(bin_bitwise_and, "bitwise-and", &, scheme_bignum_and)
GEN_BIN_INT_OP(bin_bitwise_or, "bitwise-ior", |, scheme_bignum_or)
GEN_BIN_INT_OP(bin_bitwise_xor, "bitwise-xor", ^, scheme_bignum_xor)
Scheme_Object *scheme_bin_bitwise_or(Scheme_Object *a, Scheme_Object *b)
{
return bin_bitwise_or(a, b);
}
Scheme_Object *scheme_bin_bitwise_xor(Scheme_Object *a, Scheme_Object *b)
{
return bin_bitwise_xor(a, b);
}
Scheme_Object *scheme_bin_bitwise_and(Scheme_Object *a, Scheme_Object *b)
{
return bin_bitwise_and(a, b);
}
#define MZ_PUBLIC /**/
GEN_NARY_OP(MZ_PUBLIC, scheme_bitwise_and, "bitwise-and", bin_bitwise_and, -1, SCHEME_EXACT_INTEGERP, "exact-integer?", GEN_IDENT)
@ -4315,16 +4330,12 @@ scheme_bitwise_shift(int argc, Scheme_Object *argv[])
return scheme_bignum_shift(v, shift);
}
static Scheme_Object *bitwise_bit_set_p (int argc, Scheme_Object *argv[])
static Scheme_Object *bin_bitwise_bit_set_p (Scheme_Object *so, Scheme_Object *sb, int argc, Scheme_Object **argv)
{
Scheme_Object *so, *sb;
so = argv[0];
if (!SCHEME_EXACT_INTEGERP(so)) {
scheme_wrong_contract("bitwise-bit-set?", "exact-integer?", 0, argc, argv);
ESCAPED_BEFORE_HERE;
}
sb = argv[1];
if (SCHEME_INTP(sb)) {
intptr_t v;
v = SCHEME_INT_VAL(sb);
@ -4368,6 +4379,16 @@ static Scheme_Object *bitwise_bit_set_p (int argc, Scheme_Object *argv[])
}
}
int scheme_bin_bitwise_bit_set_p (Scheme_Object *so, Scheme_Object *sb)
{
return SCHEME_TRUEP(bin_bitwise_bit_set_p(so, sb, 0, NULL));
}
static Scheme_Object *bitwise_bit_set_p (int argc, Scheme_Object *argv[])
{
return bin_bitwise_bit_set_p(argv[0], argv[1], argc, argv);
}
static Scheme_Object *slow_bitwise_bit_field (int argc, Scheme_Object *argv[],
Scheme_Object *so, Scheme_Object *sb1, Scheme_Object *sb2)
{

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1437
#define EXPECTED_PRIM_COUNT 1440
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

8
racket/src/racket/src/schpriv.h
View File

@ -2446,6 +2446,11 @@ int scheme_bin_lt_eq(const Scheme_Object *n1, const Scheme_Object *n2);
Scheme_Object *scheme_bin_quotient_remainder(const Scheme_Object *n1, const Scheme_Object *n2, Scheme_Object **_rem);
Scheme_Object *scheme_bin_bitwise_or(Scheme_Object *a, Scheme_Object *b);
Scheme_Object *scheme_bin_bitwise_xor(Scheme_Object *a, Scheme_Object *b);
Scheme_Object *scheme_bin_bitwise_and(Scheme_Object *a, Scheme_Object *b);
int scheme_bin_bitwise_bit_set_p (Scheme_Object *so, Scheme_Object *sb);
Scheme_Object *scheme_sub1(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_add1(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_odd_p(int argc, Scheme_Object *argv[]);
@ -3411,7 +3416,9 @@ int scheme_any_string_has_null(Scheme_Object *o);
Scheme_Object *scheme_do_exit(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_make_arity(mzshort minc, mzshort maxc);
Scheme_Object *scheme_make_arity_mask(intptr_t minc, intptr_t maxc);
Scheme_Object *scheme_arity(Scheme_Object *p);
Scheme_Object *scheme_arity_mask_to_arity(Scheme_Object *mask, int mode);
typedef struct {
MZTAG_IF_REQUIRED
@ -3431,6 +3438,7 @@ Scheme_Object *scheme_get_stack_trace(Scheme_Object *mark_set);
XFORM_NONGCING int scheme_fast_check_arity(Scheme_Object *v, int a);
Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, intptr_t a);
Scheme_Object *scheme_get_arity_mask(Scheme_Object *p);
int scheme_native_arity_check(Scheme_Object *closure, int argc);
Scheme_Object *scheme_get_native_arity(Scheme_Object *closure, int mode);

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "7.0.0.10"
#define MZSCHEME_VERSION "7.0.0.11"
#define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 10
#define MZSCHEME_VERSION_W 11
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

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

@ -2624,7 +2624,7 @@ static const char *startup_source =
"(begin"
"(if(if(procedure? f_0)(procedure-arity-includes? f_0 1) #f)"
"(void)"
" (let-values () (raise-argument-error 'assf \"(any/c any/c . -> . any/c)\" f_0)))"
" (let-values () (raise-argument-error 'assf \"(any/c . -> . any/c)\" f_0)))"
"((letrec-values(((loop_142)"
"(lambda(l_1 t_0)"
"(begin"