From 0a1e4e6e8355e027800dc44dd68fc28a1a6e6e5c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 18 Dec 2009 21:53:02 +0000 Subject: [PATCH] fix an allocation in bytecode compiler; add flvector equality svn: r17353 --- collects/compiler/private/xform.ss | 79 +++++++------- collects/scribblings/reference/numbers.scrbl | 4 + collects/tests/mzscheme/basic.ss | 20 ++-- src/mzscheme/src/bool.c | 13 +++ src/mzscheme/src/fun.c | 11 +- src/mzscheme/src/hash.c | 108 +++++++++++++------ src/mzscheme/src/jit.c | 15 +-- 7 files changed, 162 insertions(+), 88 deletions(-) diff --git a/collects/compiler/private/xform.ss b/collects/compiler/private/xform.ss index 190ad51e5c..febdcd2c42 100644 --- a/collects/compiler/private/xform.ss +++ b/collects/compiler/private/xform.ss @@ -1523,45 +1523,46 @@ null e))))] [(function? e) - (if (skip-function? e) - e - (let ([name (register-proto-information e)]) - (when (eq? (tok-n (car e)) '__xform_nongcing__) - (hash-table-put! non-gcing-functions name #t)) - (when show-info? (printf "/* FUNCTION ~a */~n" name)) - (if (or (positive? suspend-xform) - (not pgc?) - (and where - (regexp-match re:h where) - (let loop ([e e][prev #f]) - (cond - [(null? e) #t] - [(and (eq? '|::| (tok-n (car e))) - prev - (eq? (tok-n prev) (tok-n (cadr e)))) - ;; inline constructor: need to convert - #f] - [else (loop (cdr e) (car e))])))) - ;; Not pgc, xform suspended, - ;; or still in headers and probably a simple inlined function - (let ([palm-static? (and palm? (eq? 'static (tok-n (car e))))]) - (when palm? - (fprintf map-port "(~aimpl ~s)~n" - (if palm-static? "s" "") - name) - (call-graph name e)) - (append - (if palm-static? - ;; Need to make sure prototype is there for section - (add-segment-label - name - (let loop ([e e]) - (if (braces? (car e)) - (list (make-tok semi #f #f)) - (cons (car e) (loop (cdr e)))))) - null) - e)) - (convert-function e name))))] + (let ([name (register-proto-information e)]) + (when (eq? (tok-n (car e)) '__xform_nongcing__) + (hash-table-put! non-gcing-functions name #t)) + (if (skip-function? e) + e + (begin + (when show-info? (printf "/* FUNCTION ~a */~n" name)) + (if (or (positive? suspend-xform) + (not pgc?) + (and where + (regexp-match re:h where) + (let loop ([e e][prev #f]) + (cond + [(null? e) #t] + [(and (eq? '|::| (tok-n (car e))) + prev + (eq? (tok-n prev) (tok-n (cadr e)))) + ;; inline constructor: need to convert + #f] + [else (loop (cdr e) (car e))])))) + ;; Not pgc, xform suspended, + ;; or still in headers and probably a simple inlined function + (let ([palm-static? (and palm? (eq? 'static (tok-n (car e))))]) + (when palm? + (fprintf map-port "(~aimpl ~s)~n" + (if palm-static? "s" "") + name) + (call-graph name e)) + (append + (if palm-static? + ;; Need to make sure prototype is there for section + (add-segment-label + name + (let loop ([e e]) + (if (braces? (car e)) + (list (make-tok semi #f #f)) + (cons (car e) (loop (cdr e)))))) + null) + e)) + (convert-function e name)))))] [(var-decl? e) (when show-info? (printf "/* VAR */~n")) (if (and can-drop-vars? diff --git a/collects/scribblings/reference/numbers.scrbl b/collects/scribblings/reference/numbers.scrbl index 972ec64b73..36cdcc0dd2 100644 --- a/collects/scribblings/reference/numbers.scrbl +++ b/collects/scribblings/reference/numbers.scrbl @@ -909,6 +909,10 @@ indirections that make f64vectors more convenient for working with foreign libraries. The lack of indirections make unsafe @tech{flvector} access more efficient. +Two @tech{flvectors} are @scheme[equal?] if they have the same length, +and if the values in corresponding slots of the @tech{flvectors} are +@scheme[equal?]. + @defproc[(flvector? [v any/c]) boolean?]{ Returns @scheme[#t] if @scheme[v] is a @tech{flvector}, @scheme[#f] otherwise.} diff --git a/collects/tests/mzscheme/basic.ss b/collects/tests/mzscheme/basic.ss index 253b6ebc03..d7ff0673ab 100644 --- a/collects/tests/mzscheme/basic.ss +++ b/collects/tests/mzscheme/basic.ss @@ -3,6 +3,8 @@ (Section 'basic) +(require scheme/flonum) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test '() 'null null) @@ -1934,7 +1936,8 @@ [l (list 1 2 3)] [v (vector 5 6 7)] [a (make-a 1 (make-a 2 3))] - [b (box (list 1 2 3))]) + [b (box (list 1 2 3))] + [fl (flvector 1.0 +nan.0 0.0)]) (test 0 hash-count h1) @@ -1947,7 +1950,8 @@ (hash-set! h1 (save 3.45) 'flonum) (hash-set! h1 (save 3/45) 'rational) (hash-set! h1 (save 3+45i) 'complex) - (hash-set! h1 (save (integer->char 955)) 'char))] + (hash-set! h1 (save (integer->char 955)) 'char) + (hash-set! h1 (save fl) 'flvector))] [puts2 (lambda () (hash-set! h1 (save (list 5 7)) 'another-list) (hash-set! h1 (save 3+0.0i) 'izi-complex) @@ -1962,7 +1966,7 @@ (puts1)) (begin (puts1) - (test 7 hash-count h1) + (test 8 hash-count h1) (puts2)))) (when reorder? @@ -1974,7 +1978,7 @@ (loop (add1 i)) (hash-remove! h1 i)))) - (test 13 hash-count h1) + (test 14 hash-count h1) (test 'list hash-ref h1 l) (test 'list hash-ref h1 (list 1 2 3)) (test 'another-list hash-ref h1 (list 5 7)) @@ -1993,6 +1997,7 @@ (test 'box hash-ref h1 b) (test 'box hash-ref h1 #&(1 2 3)) (test 'char hash-ref h1 (integer->char 955)) + (test 'flvector hash-ref h1 (flvector 1.0 +nan.0 0.0)) (test #t andmap (lambda (i) @@ -2010,13 +2015,14 @@ (,(make-a 1 (make-a 2 3)) . struct) (,an-ax . structx) (#\u3BB . char) - (#&(1 2 3) . box))) + (#&(1 2 3) . box) + (,(flvector 1.0 +nan.0 0.0) . flvector))) (hash-remove! h1 (list 1 2 3)) - (test 12 hash-count h1) + (test 13 hash-count h1) (test 'not-there hash-ref h1 l (lambda () 'not-there)) (let ([c 0]) (hash-for-each h1 (lambda (k v) (set! c (add1 c)))) - (test 12 'count c)) + (test 13 'count c)) ;; return the hash table: h1)) diff --git a/src/mzscheme/src/bool.c b/src/mzscheme/src/bool.c index b9b97b1014..d8e5553956 100644 --- a/src/mzscheme/src/bool.c +++ b/src/mzscheme/src/bool.c @@ -388,6 +388,19 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) if (union_check(obj1, obj2, eql)) return 1; return vector_equal(obj1, obj2, eql); + } else if (SCHEME_FLVECTORP(obj1)) { + long l1, l2, i; + l1 = SCHEME_FLVEC_SIZE(obj1); + l2 = SCHEME_FLVEC_SIZE(obj2); + if (l1 == l2) { + for (i = 0; i < l1; i++) { + if (!double_eqv(SCHEME_FLVEC_ELS(obj1)[i], + SCHEME_FLVEC_ELS(obj2)[i])) + return 0; + } + return 1; + } + return 0; } else if (SCHEME_BYTE_STRINGP(obj1) || SCHEME_GENERAL_PATHP(obj1)) { int l1, l2; diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index a2a92f0297..9827180bed 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -1467,8 +1467,13 @@ scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, if (captured && (captured->count > offset)) { /* We need to extend the closure map. All the info is in captured, so just build it from scratch. */ - int old_pos, j; - closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * (captured->count + (has_tl ? 1 : 0))); + int old_pos, j, new_size; + new_size = (captured->count + (has_tl ? 1 : 0)); + if (cl->flonum_map) + new_size += boxmap_size(data->num_params + new_size); + closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * new_size); + if (cl->flonum_map) + memset(closure_map, 0, sizeof(mzshort) * new_size); offset = captured->count; convert_boxes = NULL; for (j = captured->size; j--; ) { @@ -1519,7 +1524,7 @@ scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, int bsz; bsz = boxmap_size(convert_size); memcpy(closure_map XFORM_OK_PLUS (has_tl ? 1 : 0), - convert_boxes, + convert_boxes, bsz * sizeof(mzshort)); } } else diff --git a/src/mzscheme/src/hash.c b/src/mzscheme/src/hash.c index d495b800f8..8ed5c928aa 100644 --- a/src/mzscheme/src/hash.c +++ b/src/mzscheme/src/hash.c @@ -945,6 +945,47 @@ static long overflow_equal_hash_key(Scheme_Object *o, long k, Hash_Info *hi) return val; } +XFORM_NONGCING static long dbl_hash_val(double d) + XFORM_SKIP_PROC +{ + int e; + + if (MZ_IS_NAN(d)) { + d = 0.0; + e = 1000; + } else if (MZ_IS_POS_INFINITY(d)) { + d = 0.5; + e = 1000; + } else if (MZ_IS_NEG_INFINITY(d)) { + d = -0.5; + e = 1000; + } else if (!d && scheme_minus_zero_p(d)) { + d = 0; + e = 1000; + } else { + /* frexp should not be used on inf or nan: */ + d = frexp(d, &e); + } + + return ((long)(d * (1 << 30))) + e; +} + +XFORM_NONGCING static long dbl_hash2_val(double d) + XFORM_SKIP_PROC +{ + int e; + + if (MZ_IS_NAN(d) + || MZ_IS_POS_INFINITY(d) + || MZ_IS_NEG_INFINITY(d)) { + e = 1; + } else { + /* frexp should not be used on inf or nan: */ + d = frexp(d, &e); + } + return e; +} + #define OVERFLOW_HASH() overflow_equal_hash_key(o, k - t, hi) /* Based on Bob Jenkins's one-at-a-time hash function at @@ -971,26 +1012,7 @@ static long equal_hash_key(Scheme_Object *o, long k, Hash_Info *hi) #endif case scheme_double_type: { - double d; - int e; - d = SCHEME_DBL_VAL(o); - if (MZ_IS_NAN(d)) { - d = 0.0; - e = 1000; - } else if (MZ_IS_POS_INFINITY(d)) { - d = 0.5; - e = 1000; - } else if (MZ_IS_NEG_INFINITY(d)) { - d = -0.5; - e = 1000; - } else if (!d && scheme_minus_zero_p(d)) { - d = 0; - e = 1000; - } else { - /* frexp should not be used on inf or nan: */ - d = frexp(d, &e); - } - return k + ((long)(d * (1 << 30))) + e; + return k + dbl_hash_val(SCHEME_DBL_VAL(o)); } case scheme_bignum_type: { @@ -1059,6 +1081,22 @@ static long equal_hash_key(Scheme_Object *o, long k, Hash_Info *hi) o = SCHEME_VEC_ELS(o)[len]; break; } + case scheme_flvector_type: + { + long len = SCHEME_FLVEC_SIZE(o), i; + double d; + + if (!len) + return k + 1; + + for (i = 0; i < len; i++) { + SCHEME_USE_FUEL(1); + d = SCHEME_FLVEC_ELS(o)[i]; + k = (k << 5) + k + dbl_hash_val(d); + } + + return k; + } case scheme_char_type: return k + SCHEME_CHAR_VAL(o); case scheme_byte_string_type: @@ -1396,18 +1434,7 @@ static long equal_hash_key2(Scheme_Object *o, Hash_Info *hi) #endif case scheme_double_type: { - double d; - int e; - d = SCHEME_FLOAT_VAL(o); - if (MZ_IS_NAN(d) - || MZ_IS_POS_INFINITY(d) - || MZ_IS_NEG_INFINITY(d)) { - e = 1; - } else { - /* frexp should not be used on inf or nan: */ - d = frexp(d, &e); - } - return e; + return dbl_hash2_val(SCHEME_FLOAT_VAL(o)); } case scheme_bignum_type: return SCHEME_BIGDIG(o)[0]; @@ -1454,6 +1481,23 @@ static long equal_hash_key2(Scheme_Object *o, Hash_Info *hi) k += equal_hash_key2(SCHEME_VEC_ELS(o)[i], hi); } + return k; + } + case scheme_flvector_type: + { + long len = SCHEME_FLVEC_SIZE(o), i; + double d; + long k = 0; + + if (!len) + return k + 1; + + for (i = 0; i < len; i++) { + SCHEME_USE_FUEL(1); + d = SCHEME_FLVEC_ELS(o)[i]; + k = (k << 5) + k + dbl_hash2_val(d); + } + return k; } case scheme_char_type: diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 26fdd08b34..5c41fa3ace 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -638,7 +638,7 @@ static void *generate_one(mz_jit_state *old_jitter, if (ok) { /* That was big enough: */ if (jitter->unbox || jitter->unbox_depth) - scheme_signal_error("ended with unbox or depth"); + scheme_signal_error("internal error: ended with unbox or depth"); if (known_size) { /* That was in the permanent area, so return: */ jit_flush_code(buffer, jit_get_ip().ptr); @@ -4468,7 +4468,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj unsafe_fl = 1; if (!args_unboxed && rand) - scheme_signal_error("unvalid mode"); + scheme_signal_error("internal error: invalid mode"); if (inlined_flonum1 && !inlined_flonum2) { GC_CAN_IGNORE Scheme_Object *tmp; @@ -4571,7 +4571,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj --jitter->unbox; jitter->unbox_depth -= flonum_depth; if (!jitter->unbox && jitter->unbox_depth && rand) - scheme_signal_error("broken unbox depth"); + scheme_signal_error("internal error: broken unbox depth"); if (for_branch) mz_rs_sync(); /* needed if arguments were unboxed */ @@ -5190,7 +5190,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj ref3 = jit_bmcr_l(jit_forward(), JIT_R0, JIT_R2); } else { /* shouldn't get here */ - scheme_signal_error("bitwise-bit-test? constant in wrong position"); + scheme_signal_error("internal error: bitwise-bit-test? constant in wrong position"); ref3 = NULL; } break; @@ -6789,7 +6789,8 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i which = 3; base_offset = ((int)&SCHEME_FLVEC_ELS(0x0)); if (unbox) { - if (jitter->unbox_depth) scheme_signal_error("bad depth for flvector-ref"); + if (jitter->unbox_depth) + scheme_signal_error("internal error: bad depth for flvector-ref"); jitter->unbox = 0; } } else if (IS_NAMED_PRIM(rator, "unsafe-struct-ref")) { @@ -7996,7 +7997,7 @@ static int generate_unboxed(Scheme_Object *obj, mz_jit_state *jitter, int inline } if (!jitter->unbox || jitter->unbox_depth) - scheme_signal_error("bad unboxing mode or depth"); + scheme_signal_error("internal error: bad unboxing mode or depth"); /* It probably would be useful to special-case a let-one sequence down to something that can be unboxed. */ @@ -8497,7 +8498,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m break; case SPLICE_EXPD: { - scheme_signal_error("cannot JIT a top-level splice form"); + scheme_signal_error("internal error: cannot JIT a top-level splice form"); } break; default: