diff --git a/collects/data/bit-vector.rkt b/collects/data/bit-vector.rkt index 56443b494f..675a381e07 100644 --- a/collects/data/bit-vector.rkt +++ b/collects/data/bit-vector.rkt @@ -138,6 +138,7 @@ (define-vector-wraps "bit-vector" + "boolean?" boolean? bit-vector? bit-vector-length bit-vector-ref bit-vector-set! make-bit-vector unsafe-bit-vector-ref bit-vector-set! bit-vector-length in-bit-vector* diff --git a/collects/racket/extflonum.rkt b/collects/racket/extflonum.rkt index c191ecc6d6..8e187bd4d4 100644 --- a/collects/racket/extflonum.rkt +++ b/collects/racket/extflonum.rkt @@ -11,6 +11,7 @@ extflvector-copy) (define-vector-wraps "extflvector" + "extflonum?" extflonum? extflvector? extflvector-length extflvector-ref extflvector-set! make-extflvector unsafe-extflvector-ref unsafe-extflvector-set! unsafe-extflvector-length in-extflvector* diff --git a/collects/racket/fixnum.rkt b/collects/racket/fixnum.rkt index c38da67528..20fe409155 100644 --- a/collects/racket/fixnum.rkt +++ b/collects/racket/fixnum.rkt @@ -20,6 +20,7 @@ in-fxvector for/fxvector for*/fxvector) (define-vector-wraps "fxvector" + "fixnum?" fixnum? fxvector? fxvector-length fxvector-ref fxvector-set! make-fxvector unsafe-fxvector-ref unsafe-fxvector-set! unsafe-fxvector-length in-fxvector* diff --git a/collects/racket/flonum.rkt b/collects/racket/flonum.rkt index bfa03477b0..e89a62b3a6 100644 --- a/collects/racket/flonum.rkt +++ b/collects/racket/flonum.rkt @@ -19,6 +19,7 @@ in-flvector for/flvector for*/flvector) (define-vector-wraps "flvector" + "flonum?" flonum? flvector? flvector-length flvector-ref flvector-set! make-flvector unsafe-flvector-ref unsafe-flvector-set! unsafe-flvector-length in-flvector* diff --git a/collects/racket/private/for.rkt b/collects/racket/private/for.rkt index 65208e778c..6dadd5a1d3 100644 --- a/collects/racket/private/for.rkt +++ b/collects/racket/private/for.rkt @@ -1497,10 +1497,10 @@ [i 0]) (for-clause ...) middle-body ... - (let ([new-vec (if (eq? i (unsafe-vector-length vec)) + (let ([new-vec (if (eq? i (unsafe-vector*-length vec)) (grow-vector vec) vec)]) - (unsafe-vector-set! new-vec i (let () last-body ...)) + (unsafe-vector*-set! new-vec i (let () last-body ...)) (values new-vec (unsafe-fx+ i 1))))]) (shrink-vector vec i))))] [(_ #:length length-expr #:fill fill-expr (for-clause ...) body ...) @@ -1546,8 +1546,8 @@ ([i 0]) (limited-for-clause ...) middle-body ... - (vector-set! v i (let () last-body ...)) - (add1 i))) + (unsafe-vector*-set! v i (let () last-body ...)) + (unsafe-fx+ 1 i))) v))))] [(_ #:length length-expr (for-clause ...) body ...) (for_/vector #'(fv #:length length-expr #:fill 0 (for-clause ...) body ...) diff --git a/collects/racket/private/vector-wraps.rkt b/collects/racket/private/vector-wraps.rkt index 395bf2f57c..2513b68010 100644 --- a/collects/racket/private/vector-wraps.rkt +++ b/collects/racket/private/vector-wraps.rkt @@ -9,6 +9,7 @@ (define-syntax-rule (define-vector-wraps fXvector-str + fX?-str fX? fXvector? fXvector-length fXvector-ref fXvector-set! make-fXvector unsafe-fXvector-ref unsafe-fXvector-set! unsafe-fXvector-length in-fXvector* @@ -50,6 +51,9 @@ (unsafe-fXvector-copy! new-vec 0 vec 0 i) new-vec) + (define (not-an-fX who v) + (raise-argument-error who fX?-str v)) + (define-for-syntax (for_/fXvector stx orig-stx for_/fXvector-stx for_/fold/derived-stx wrap-all?) (syntax-case stx () [(for*/fXvector (for-clause ...) body ...) @@ -67,7 +71,10 @@ (let ([new-vec (if (eq? i (unsafe-fXvector-length vec)) (grow-fXvector vec) vec)]) - (fXvector-set! new-vec i (let () last-body ...)) + (let ([elem (let () last-body ...)]) + (if (fX? elem) + (unsafe-fXvector-set! new-vec i elem) + (not-an-fX 'for*/fXvector elem))) (values new-vec (unsafe-fx+ i 1))))]) (shrink-fXvector vec i))))] [(for*/fXvector #:length length-expr #:fill fill-expr (for-clause ...) body ...) @@ -114,8 +121,11 @@ ([i 0]) (limited-for-clause ...) middle-body ... - (fXvector-set! v i (let () last-body ...)) - (add1 i))) + (let ([elem (let () last-body ...)]) + (if (fX? elem) + (unsafe-fXvector-set! v i elem) + (not-an-fX 'for*/vector elem))) + (unsafe-fx+ 1 i))) v)))))] [(_ #:length length-expr (for-clause ...) body ...) (for_/fXvector #'(fv #:length length-expr #:fill fXzero (for-clause ...) body ...) diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index 768dbb52e2..8b974b6788 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -1788,6 +1788,32 @@ (+ p (unsafe-fx- p 1) (- p p) t)) 'ok)))) +;; eliminate unneeded tests: +(test-comp '(lambda (n) + (let ([p (fl+ n n)]) + (if (flonum? p) + (fl+ p p) + 'bad))) + '(lambda (n) + (let ([p (fl+ n n)]) + (fl+ p p)))) +(test-comp '(lambda (n) + (let ([p (fx+ n n)]) + (if (fixnum? p) + (fx+ p p) + 'bad))) + '(lambda (n) + (let ([p (fx+ n n)]) + (fx+ p p)))) +(test-comp '(lambda (n) + (let ([p (extfl+ n n)]) + (if (extflonum? p) + (extfl+ p p) + 'bad))) + '(lambda (n) + (let ([p (extfl+ n n)]) + (extfl+ p p)))) + ;; simple cross-module inlining (test-comp `(module m racket/base (require racket/bool) diff --git a/src/racket/src/number.c b/src/racket/src/number.c index 95439259ce..b65b14af26 100644 --- a/src/racket/src/number.c +++ b/src/racket/src/number.c @@ -815,7 +815,8 @@ void scheme_init_flfxnum_number(Scheme_Env *env) flags = SCHEME_PRIM_IS_UNARY_INLINED; else flags = SCHEME_PRIM_SOMETIMES_INLINED; - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags + | SCHEME_PRIM_PRODUCES_FLONUM); scheme_add_global_constant("->fl", p, env); p = scheme_make_folding_prim(fl_to_integer, "fl->exact-integer", 1, 1, 1); diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index f96bb95973..c166a5c1c6 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -2361,6 +2361,29 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz info->single_result = -info->single_result; } + /* Check for things like (flonum? x) on an `x' known to have a flonum value. */ + if (SCHEME_PRIMP(app->rator) + && (SCHEME_PRIM_PROC_OPT_FLAGS(app->rator) & SCHEME_PRIM_IS_UNARY_INLINED) + && SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type)) { + int pos = SCHEME_LOCAL_POS(app->rand); + + if (!optimize_is_mutated(info, pos)) { + int t; + t = optimize_is_local_type_valued(info, pos); + + if (t == SCHEME_LOCAL_TYPE_FLONUM) { + if (IS_NAMED_PRIM(app->rator, "flonum?")) + return scheme_true; + } else if (t == SCHEME_LOCAL_TYPE_FIXNUM) { + if (IS_NAMED_PRIM(app->rator, "fixnum?")) + return scheme_true; + } else if (t == SCHEME_LOCAL_TYPE_EXTFLONUM) { + if (IS_NAMED_PRIM(app->rator, "extflonum?")) + return scheme_true; + } + } + } + /* Check for things like (cXr (cons X Y)): */ if (SCHEME_PRIMP(app->rator) && (SCHEME_PRIM_PROC_OPT_FLAGS(app->rator) & SCHEME_PRIM_IS_UNARY_INLINED)) {