From ecbd6f1578ca84771ec803c97e9fc1cc44a75046 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 9 Aug 2018 06:23:27 -0600 Subject: [PATCH] add `procedure-arity-mask` and `procedure-reduce-arity-mask` 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. --- pkgs/base/info.rkt | 2 +- .../scribblings/reference/exns.scrbl | 11 + .../scribblings/reference/procedures.scrbl | 50 +- pkgs/racket-test-core/tests/racket/basic.rktl | 13 +- .../racket-test-core/tests/racket/object.rktl | 51 -- pkgs/racket-test-core/tests/racket/procs.rktl | 89 +++- racket/collects/racket/private/kw.rkt | 152 +++--- racket/collects/racket/private/norm-arity.rkt | 21 +- racket/collects/racket/private/pre-base.rkt | 7 +- racket/src/cs/primitive/kernel.ss | 5 +- racket/src/cs/rumble.sls | 3 + racket/src/cs/rumble/error.ss | 9 +- racket/src/cs/rumble/procedure.ss | 107 ++-- racket/src/expander/Makefile | 6 +- racket/src/expander/extract/gc-defn.rkt | 41 +- .../src/expander/extract/known-primitive.rkt | 3 +- racket/src/expander/extract/main.rkt | 8 +- racket/src/expander/run.rkt | 8 +- racket/src/racket/src/error.c | 47 +- racket/src/racket/src/fun.c | 476 +++++++++++------- racket/src/racket/src/jit.c | 53 +- racket/src/racket/src/jitcall.c | 8 +- racket/src/racket/src/number.c | 31 +- racket/src/racket/src/schminc.h | 2 +- racket/src/racket/src/schpriv.h | 8 + racket/src/racket/src/schvers.h | 4 +- racket/src/racket/src/startup.inc | 2 +- 27 files changed, 785 insertions(+), 432 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 4df2125a53..03291544f5 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -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])) diff --git a/pkgs/racket-doc/scribblings/reference/exns.scrbl b/pkgs/racket-doc/scribblings/reference/exns.scrbl index e6d0fe8601..ae1f1e1537 100644 --- a/pkgs/racket-doc/scribblings/reference/exns.scrbl +++ b/pkgs/racket-doc/scribblings/reference/exns.scrbl @@ -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)] diff --git a/pkgs/racket-doc/scribblings/reference/procedures.scrbl b/pkgs/racket-doc/scribblings/reference/procedures.scrbl index 65d1dabd5d..83a959c43d 100644 --- a/pkgs/racket-doc/scribblings/reference/procedures.scrbl +++ b/pkgs/racket-doc/scribblings/reference/procedures.scrbl @@ -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)) +(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 diff --git a/pkgs/racket-test-core/tests/racket/basic.rktl b/pkgs/racket-test-core/tests/racket/basic.rktl index 070de07506..efdc436f11 100644 --- a/pkgs/racket-test-core/tests/racket/basic.rktl +++ b/pkgs/racket-test-core/tests/racket/basic.rktl @@ -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)) diff --git a/pkgs/racket-test-core/tests/racket/object.rktl b/pkgs/racket-test-core/tests/racket/object.rktl index db12dd35cf..31c6102336 100644 --- a/pkgs/racket-test-core/tests/racket/object.rktl +++ b/pkgs/racket-test-core/tests/racket/object.rktl @@ -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.: diff --git a/pkgs/racket-test-core/tests/racket/procs.rktl b/pkgs/racket-test-core/tests/racket/procs.rktl index 25e6dcaa6e..865b8ff38b 100644 --- a/pkgs/racket-test-core/tests/racket/procs.rktl +++ b/pkgs/racket-test-core/tests/racket/procs.rktl @@ -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)))) diff --git a/racket/collects/racket/private/kw.rkt b/racket/collects/racket/private/kw.rkt index 1aae77a30f..685511f12e 100644 --- a/racket/collects/racket/private/kw.rkt +++ b/racket/collects/racket/private/kw.rkt @@ -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) - (okp-ref proc 0) - proc) - arity)]) + (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)]) + (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,20 +1646,63 @@ 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) - (if (and (procedure? proc) - (let-values ([(req allows) (procedure-keywords proc)]) - (pair? req)) - (not (null? arity))) - (raise-arguments-error 'procedure-reduce-arity - "procedure has required keyword arguments" - "procedure" proc) - (procedure-reduce-arity (if (okm? proc) - (procedure->method proc) - proc) - arity)))]) + (case-lambda + [(proc arity name) + (if (and (procedure? proc) + (let-values ([(req allows) (procedure-keywords proc)]) + (pair? req)) + (not (null? arity))) + (raise-arguments-error 'procedure-reduce-arity + "procedure has required keyword arguments" + "procedure" proc) + (procedure-reduce-arity (if (okm? proc) + (procedure->method proc) + proc) + 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 diff --git a/racket/collects/racket/private/norm-arity.rkt b/racket/collects/racket/private/norm-arity.rkt index 246b7f8abd..98229e2c98 100644 --- a/racket/collects/racket/private/norm-arity.rkt +++ b/racket/collects/racket/private/norm-arity.rkt @@ -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 diff --git a/racket/collects/racket/private/pre-base.rkt b/racket/collects/racket/private/pre-base.rkt index 155c136f1a..38a6827df8 100644 --- a/racket/collects/racket/private/pre-base.rkt +++ b/racket/collects/racket/private/pre-base.rkt @@ -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 diff --git a/racket/src/cs/primitive/kernel.ss b/racket/src/cs/primitive/kernel.ss index be10ce9f2b..d15ca8c87c 100644 --- a/racket/src/cs/primitive/kernel.ss +++ b/racket/src/cs/primitive/kernel.ss @@ -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)] diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index 061b49d14e..1de0534f7f 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -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 diff --git a/racket/src/cs/rumble/error.ss b/racket/src/cs/rumble/error.ss index eadf4f246c..ce9e697d8b 100644 --- a/racket/src/cs/rumble/error.ss +++ b/racket/src/cs/rumble/error.ss @@ -328,7 +328,14 @@ (expected-arity-string arity) " 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"))]) diff --git a/racket/src/cs/rumble/procedure.ss b/racket/src/cs/rumble/procedure.ss index e6a59e8f22..d4da99d8b2 100644 --- a/racket/src/cs/rumble/procedure.ss +++ b/racket/src/cs/rumble/procedure.ss @@ -241,49 +241,70 @@ (define-record reduced-arity-procedure (proc mask name)) -(define/who (procedure-reduce-arity proc a) - (check who procedure? proc) - (let ([mask (arity->mask a)]) - (unless mask - (raise-arguments-error who "procedure-arity?" a)) - (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)) - (let ([name (object-name proc)]) - (case mask - [(1) (make-arity-wrapper-procedure (if (#%procedure? proc) - (lambda () (proc)) - (lambda () (|#%app| proc))) - mask - name)] - [(2) (make-arity-wrapper-procedure (if (#%procedure? proc) - (lambda (x) (proc x)) - (lambda (x) (|#%app| proc x))) - mask - name)] - [(4) (make-arity-wrapper-procedure (if (#%procedure? proc) - (lambda (x y) (proc x y)) - (lambda (x y) (|#%app| proc x y))) - mask - name)] - [(8) (make-arity-wrapper-procedure (if (#%procedure? proc) - (lambda (x y z) (proc x y z)) - (lambda (x y z) (|#%app| proc x y z))) - mask - name)] - [else - (make-reduced-arity-procedure - (lambda args - (unless (bitwise-bit-set? mask (length args)) - (apply raise-arity-error - (or (object-name proc) 'procedure) - (mask->arity mask) - args)) - (apply proc args)) - mask - name)])))) +(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) + (lambda () (proc)) + (lambda () (|#%app| proc))) + mask + name)] + [(2) (make-arity-wrapper-procedure (if (#%procedure? proc) + (lambda (x) (proc x)) + (lambda (x) (|#%app| proc x))) + mask + name)] + [(4) (make-arity-wrapper-procedure (if (#%procedure? proc) + (lambda (x y) (proc x y)) + (lambda (x y) (|#%app| proc x y))) + mask + name)] + [(8) (make-arity-wrapper-procedure (if (#%procedure? proc) + (lambda (x y z) (proc x y z)) + (lambda (x y z) (|#%app| proc x y z))) + mask + name)] + [else + (make-reduced-arity-procedure + (lambda args + (unless (bitwise-bit-set? mask (length args)) + (apply raise-arity-error + (or (object-name proc) 'procedure) + (mask->arity mask) + args)) + (apply proc args)) + mask + name)]))) ;; ---------------------------------------- diff --git a/racket/src/expander/Makefile b/racket/src/expander/Makefile index c680fbf91c..def75cbfff 100644 --- a/racket/src/expander/Makefile +++ b/racket/src/expander/Makefile @@ -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 diff --git a/racket/src/expander/extract/gc-defn.rkt b/racket/src/expander/extract/gc-defn.rkt index 3b8f60950b..e0c590e967 100644 --- a/racket/src/expander/extract/gc-defn.rkt +++ b/racket/src/expander/extract/gc-defn.rkt @@ -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)]) diff --git a/racket/src/expander/extract/known-primitive.rkt b/racket/src/expander/extract/known-primitive.rkt index d42e987676..1f366e0684 100644 --- a/racket/src/expander/extract/known-primitive.rkt +++ b/racket/src/expander/extract/known-primitive.rkt @@ -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)))) diff --git a/racket/src/expander/extract/main.rkt b/racket/src/expander/extract/main.rkt index c1c316fd6b..e6b1f223ee 100644 --- a/racket/src/expander/extract/main.rkt +++ b/racket/src/expander/extract/main.rkt @@ -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)) diff --git a/racket/src/expander/run.rkt b/racket/src/expander/run.rkt index 61acfc53ce..aea8de6419 100644 --- a/racket/src/expander/run.rkt +++ b/racket/src/expander/run.rkt @@ -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) @@ -100,7 +101,9 @@ [("++depend") file "Record as a dependency" (hash-set! dependencies (simplify-path (path->complete-path file)) #t)] [("++depend-module") mod-file "Add and transitive as dependencies" - (set! extra-module-dependencies (cons mod-file extra-module-dependencies))] + (set! extra-module-dependencies (cons mod-file extra-module-dependencies))] + [("++disallow") id "If 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)) diff --git a/racket/src/racket/src/error.c b/racket/src/racket/src/error.c index 0e5bbf7a8f..936302b885 100644 --- a/racket/src/racket/src/error.c +++ b/racket/src/racket/src/error.c @@ -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", - "(or/c exact-nonnegative-integer? arity-at-least? (listof (or/c exact-nonnegative-integer? arity-at-least?)))", - 1, argc, argv); + 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; diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 4c25b0acf9..1fbf33c67a 100644 --- a/racket/src/racket/src/fun.c +++ b/racket/src/racket/src/fun.c @@ -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; - } - 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)); + Scheme_Object *a[2]; + a[0] = n; + a[1] = scheme_make_integer(-drop); + return scheme_bitwise_shift(2, a); +} + +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); +} + +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 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 { - p[0] = a; - return scheme_make_struct_instance(scheme_arity_at_least, 1, p); + return scheme_bin_bitwise_xor(scheme_bin_minus(make_shifted_one(mina), scheme_make_integer(1)), + scheme_make_integer(-1)); } - } else if (SCHEME_NULLP(a)) - return a; - else if (delta) - return scheme_bin_minus(a, scheme_make_integer(delta)); - else - return a; + } 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,101 +1850,86 @@ 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 (SAME_TYPE(SCHEME_TYPE(v), scheme_lambda_type)) - data = (Scheme_Lambda *)v; - else - data = SCHEME_CLOSURE_CODE(v); - mina = maxa = data->num_params; - if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) { - if (mina) - --mina; - maxa = -1; - } - - if (a >= 0) { - if ((a + drop) >= mina && (maxa < 0 || (a + drop) <= maxa)) - return scheme_true; - } else if (a == -2) { - if (maxa < 0) - return scheme_true; + if ((a == -1) || (a == -3) || (a == -4)) { + mask = scheme_bin_bitwise_or(get_or_check_arity(v, -4, NULL, inc_ok), mask); } else { - if (mina >= drop) { - mina -= drop; - if (maxa > 0) - maxa -= drop; + if (SAME_TYPE(SCHEME_TYPE(v), scheme_lambda_type)) + data = (Scheme_Lambda *)v; + else + data = SCHEME_CLOSURE_CODE(v); + mina = maxa = data->num_params; + if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) { + if (mina) + --mina; + maxa = -1; + } - v = scheme_make_pair(make_arity(mina, maxa, a), scheme_null); - if (!last) - first = v; - else - SCHEME_CDR(last) = v; - last = v; - } + if (a >= 0) { + if ((a + drop) >= mina && (maxa < 0 || (a + drop) <= maxa)) + return scheme_true; + } else if (a == -2) { + if (maxa < 0) + return scheme_true; + } } } - return first; + 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 + 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)) - return scheme_false; + && 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; - } else { - if (scheme_bin_eq(x, bign)) - return scheme_true; - } - v = SCHEME_CDR(v); - } + 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_bitwise_bit_set_p(((Scheme_Structure *)p)->slots[1], bign)) + return scheme_true; + 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)) { - 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); - } + 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); + + for (i = 0; i < count; i++) { + mask = scheme_bin_bitwise_or(make_arity_mask(cases[2 * i], cases[(2 * i)+1]), mask); } - - /* If drop > 0, might have found no matches */ - if (!SCHEME_NULLP(ae)) { - if (last) - SCHEME_CDR(last) = scheme_null; - else - arity = scheme_null; - } - - return arity; + if (drop) + mask = shift_for_drop(mask, drop); + + + if (a == -4) + return mask; + else + 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; - else + 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 (!is_arity(argv[1], 1, 1)) { - scheme_wrong_contract("procedure-reduce-arity", - "(or/c exact-nonnegative-integer? arity-at-least? (listof (or/c exact-nonnegative-integer? arity-at-least?)))", - 1, argc, argv); + if (as_arity) { + if (!is_arity(argv[1], 1, 1)) { + 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; + } } + + 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; - /* 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. */ + /* Check whether current arity covers the requested arity. */ - orig = get_or_check_arity(argv[0], -1, NULL, 1); - aty = clone_arity(argv[1], 0, -1); + orig = get_or_check_arity(argv[0], -4, NULL, 1); - if (!is_subarity(aty, orig, 0)) { - scheme_contract_error("procedure-reduce-arity", - "arity of procedure does not include requested arity", + 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[]) diff --git a/racket/src/racket/src/jit.c b/racket/src/racket/src/jit.c index da16ee9c96..51db280391 100644 --- a/racket/src/racket/src/jit.c +++ b/racket/src/racket/src/jit.c @@ -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); } - if (is_method) - l = scheme_box(l); return l; } @@ -4505,13 +4501,30 @@ 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; - 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) { + 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; + } } - return sjc.get_arity_code(closure, 0, 0 EXTRA_NATIVE_ARGUMENT); + 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); } /**********************************************************************/ diff --git a/racket/src/racket/src/jitcall.c b/racket/src/racket/src/jitcall.c index 9ad1b402dd..401e368a4c 100644 --- a/racket/src/racket/src/jitcall.c +++ b/racket/src/racket/src/jitcall.c @@ -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); diff --git a/racket/src/racket/src/number.c b/racket/src/racket/src/number.c index b2c133211d..428e53fe0c 100644 --- a/racket/src/racket/src/number.c +++ b/racket/src/racket/src/number.c @@ -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) { diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h index 3a88ead3c1..f3ed9882f8 100644 --- a/racket/src/racket/src/schminc.h +++ b/racket/src/racket/src/schminc.h @@ -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 diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index e66f51aaa7..e19c4ff701 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -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); diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index ee9722371a..dfbff86ee0 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -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) diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 4f7f439765..5a1139aa29 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -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"