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

fix an allocation in bytecode compiler; add flvector equality

Browse Source 
svn: r17353
This commit is contained in:
Matthew Flatt 2009-12-18 21:53:02 +00:00
parent 35040e040c
commit 0a1e4e6e83
7 changed files with 162 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
collects/compiler/private/xform.ss
View File

@ -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?

4
collects/scribblings/reference/numbers.scrbl
View File

@ -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.}

20
collects/tests/mzscheme/basic.ss
View File

@ -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))

13
src/mzscheme/src/bool.c
View File

@ -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;

11
src/mzscheme/src/fun.c
View File

@ -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

108
src/mzscheme/src/hash.c
View File

@ -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:

15
src/mzscheme/src/jit.c
View File

@ -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: