From 32b95c2cdfda7b9e7139127e4f8c78199bf80b58 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Sep 2009 22:20:13 -0500 Subject: [PATCH 1/7] math: add unordered comparison operators u< u<= u> u>= which behave exactly like < <= > >= except no floating point exceptions are set if one or both inputs are NaNs; also add efficient intrinsic for unordered? predicate, and fix propagation type functions for abs, absq, and bitnot --- .../cfg/intrinsics/float/float.factor | 5 +- .../compiler/cfg/intrinsics/intrinsics.factor | 15 +- basis/compiler/tests/float.factor | 12 ++ .../tree/comparisons/comparisons.factor | 36 +++-- .../known-words/known-words.factor | 56 ++++---- .../tree/propagation/propagation-tests.factor | 65 +++++++++ basis/math/floats/env/env-tests.factor | 130 ++++++++++++------ basis/math/floats/env/env.factor | 2 +- .../partial-dispatch/partial-dispatch.factor | 6 + .../known-words/known-words.factor | 18 ++- core/bootstrap/primitives.factor | 4 + core/math/floats/floats-docs.factor | 79 +++++++++-- core/math/floats/floats.factor | 13 +- core/math/integers/integers.factor | 10 ++ core/math/math-docs.factor | 43 +++++- core/math/math.factor | 7 +- vm/primitives.cpp | 6 + 17 files changed, 396 insertions(+), 111 deletions(-) diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor index 8dab157f4e..8a65de5805 100644 --- a/basis/compiler/cfg/intrinsics/float/float.factor +++ b/basis/compiler/cfg/intrinsics/float/float.factor @@ -7,7 +7,10 @@ IN: compiler.cfg.intrinsics.float : emit-float-op ( insn -- ) [ 2inputs ] dip call ds-push ; inline -: emit-float-comparison ( cc -- ) +: emit-float-ordered-comparison ( cc -- ) + [ 2inputs ] dip ^^compare-float-ordered ds-push ; inline + +: emit-float-unordered-comparison ( cc -- ) [ 2inputs ] dip ^^compare-float-unordered ds-push ; inline : emit-float>fixnum ( -- ) diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index ec567558bd..a54caf23de 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -86,13 +86,18 @@ IN: compiler.cfg.intrinsics { math.private:float- [ drop [ ^^sub-float ] emit-float-op ] } { math.private:float* [ drop [ ^^mul-float ] emit-float-op ] } { math.private:float/f [ drop [ ^^div-float ] emit-float-op ] } - { math.private:float< [ drop cc< emit-float-comparison ] } - { math.private:float<= [ drop cc<= emit-float-comparison ] } - { math.private:float>= [ drop cc>= emit-float-comparison ] } - { math.private:float> [ drop cc> emit-float-comparison ] } - { math.private:float= [ drop cc= emit-float-comparison ] } + { math.private:float< [ drop cc< emit-float-ordered-comparison ] } + { math.private:float<= [ drop cc<= emit-float-ordered-comparison ] } + { math.private:float>= [ drop cc>= emit-float-ordered-comparison ] } + { math.private:float> [ drop cc> emit-float-ordered-comparison ] } + { math.private:float-u< [ drop cc< emit-float-unordered-comparison ] } + { math.private:float-u<= [ drop cc<= emit-float-unordered-comparison ] } + { math.private:float-u>= [ drop cc>= emit-float-unordered-comparison ] } + { math.private:float-u> [ drop cc> emit-float-unordered-comparison ] } + { math.private:float= [ drop cc= emit-float-unordered-comparison ] } { math.private:float>fixnum [ drop emit-float>fixnum ] } { math.private:fixnum>float [ drop emit-fixnum>float ] } + { math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] } { alien.accessors:alien-float [ float-rep emit-alien-float-getter ] } { alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] } { alien.accessors:alien-double [ double-rep emit-alien-float-getter ] } diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index 86d7899fab..14b347008c 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -88,3 +88,15 @@ IN: compiler.tests.float [ 17.5 ] [ 17.5 -11.3 [ float-max ] compile-call ] unit-test [ -11.3 ] [ -11.3 17.5 [ float-min ] compile-call ] unit-test [ -11.3 ] [ 17.5 -11.3 [ float-min ] compile-call ] unit-test + +[ t ] [ 0/0. 0/0. [ float-unordered? ] compile-call ] unit-test +[ t ] [ 0/0. 1.0 [ float-unordered? ] compile-call ] unit-test +[ t ] [ 1.0 0/0. [ float-unordered? ] compile-call ] unit-test +[ f ] [ 3.0 1.0 [ float-unordered? ] compile-call ] unit-test +[ f ] [ 1.0 3.0 [ float-unordered? ] compile-call ] unit-test + +[ 1 ] [ 0/0. 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 1 ] [ 0/0. 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 1 ] [ 1.0 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test diff --git a/basis/compiler/tree/comparisons/comparisons.factor b/basis/compiler/tree/comparisons/comparisons.factor index 5f4b1e8dab..b8e79e33ca 100644 --- a/basis/compiler/tree/comparisons/comparisons.factor +++ b/basis/compiler/tree/comparisons/comparisons.factor @@ -1,28 +1,36 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math math.order math.intervals assocs combinators ; IN: compiler.tree.comparisons ! Some utilities for working with comparison operations. -CONSTANT: comparison-ops { < > <= >= } +CONSTANT: comparison-ops { < > <= >= u< u> u<= u>= } CONSTANT: generic-comparison-ops { before? after? before=? after=? } : assumption ( i1 i2 op -- i3 ) { - { \ < [ assume< ] } - { \ > [ assume> ] } - { \ <= [ assume<= ] } - { \ >= [ assume>= ] } + { \ < [ assume< ] } + { \ > [ assume> ] } + { \ <= [ assume<= ] } + { \ >= [ assume>= ] } + { \ u< [ assume< ] } + { \ u> [ assume> ] } + { \ u<= [ assume<= ] } + { \ u>= [ assume>= ] } } case ; : interval-comparison ( i1 i2 op -- result ) { - { \ < [ interval< ] } - { \ > [ interval> ] } - { \ <= [ interval<= ] } - { \ >= [ interval>= ] } + { \ < [ interval< ] } + { \ > [ interval> ] } + { \ <= [ interval<= ] } + { \ >= [ interval>= ] } + { \ u< [ interval< ] } + { \ u> [ interval> ] } + { \ u<= [ interval<= ] } + { \ u>= [ interval>= ] } } case ; : swap-comparison ( op -- op' ) @@ -31,6 +39,10 @@ CONSTANT: generic-comparison-ops { before? after? before=? after=? } { > < } { <= >= } { >= <= } + { u< u> } + { u> u< } + { u<= u>= } + { u>= u<= } } at ; : negate-comparison ( op -- op' ) @@ -39,6 +51,10 @@ CONSTANT: generic-comparison-ops { before? after? before=? after=? } { > <= } { <= > } { >= < } + { u< u>= } + { u> u<= } + { u<= u> } + { u>= u< } } at ; : specific-comparison ( op -- op' ) diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 5fe7d5ee1b..63d2df543d 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -23,7 +23,7 @@ IN: compiler.tree.propagation.known-words { + - * / } [ { number number } "input-classes" set-word-prop ] each -{ /f < > <= >= } +{ /f < > <= >= u< u> u<= u>= } [ { real real } "input-classes" set-word-prop ] each { /i mod /mod } @@ -34,21 +34,6 @@ IN: compiler.tree.propagation.known-words \ bitnot { integer } "input-classes" set-word-prop -: real-op ( info quot -- quot' ) - [ - dup class>> real classes-intersect? - [ clone ] [ drop real ] if - ] dip - change-interval ; inline - -{ bitnot fixnum-bitnot bignum-bitnot } [ - [ [ interval-bitnot ] real-op ] "outputs" set-word-prop -] each - -\ abs [ [ interval-abs ] real-op ] "outputs" set-word-prop - -\ absq [ [ interval-absq ] real-op ] "outputs" set-word-prop - : math-closure ( class -- newclass ) { fixnum bignum integer rational float real number object } [ class<= ] with find nip ; @@ -56,15 +41,6 @@ IN: compiler.tree.propagation.known-words : fits-in-fixnum? ( interval -- ? ) fixnum-interval interval-subset? ; -: binary-op-class ( info1 info2 -- newclass ) - [ class>> ] bi@ - 2dup [ null-class? ] either? [ 2drop null ] [ - [ math-closure ] bi@ math-class-max - ] if ; - -: binary-op-interval ( info1 info2 quot -- newinterval ) - [ [ interval>> ] bi@ ] dip call ; inline - : won't-overflow? ( class interval -- ? ) [ fixnum class<= ] [ fits-in-fixnum? ] bi* and ; @@ -101,6 +77,36 @@ IN: compiler.tree.propagation.known-words [ drop float ] dip ] unless ; +: unary-op-class ( info -- newclass ) + class>> dup null-class? [ drop null ] [ math-closure ] if ; + +: unary-op-interval ( info quot -- newinterval ) + [ interval>> ] dip call ; inline + +: unary-op ( word interval-quot post-proc-quot -- ) + '[ + [ unary-op-class ] [ _ unary-op-interval ] bi + @ + + ] "outputs" set-word-prop ; + +{ bitnot fixnum-bitnot bignum-bitnot } [ + [ interval-bitnot ] [ integer-valued ] unary-op +] each + +\ abs [ interval-abs ] [ may-overflow real-valued ] unary-op + +\ absq [ interval-absq ] [ may-overflow real-valued ] unary-op + +: binary-op-class ( info1 info2 -- newclass ) + [ class>> ] bi@ + 2dup [ null-class? ] either? [ 2drop null ] [ + [ math-closure ] bi@ math-class-max + ] if ; + +: binary-op-interval ( info1 info2 quot -- newinterval ) + [ [ interval>> ] bi@ ] dip call ; inline + : binary-op ( word interval-quot post-proc-quot -- ) '[ [ binary-op-class ] [ _ binary-op-interval ] 2bi diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 1b24bc0c8f..ec5fbd95cd 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -31,6 +31,8 @@ IN: compiler.tree.propagation.tests [ V{ 69 } ] [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test +[ V{ integer } ] [ [ bitnot ] final-classes ] unit-test + [ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test ! Test type propagation for math ops @@ -164,6 +166,18 @@ IN: compiler.tree.propagation.tests [ t ] [ [ absq ] final-info first interval>> [0,inf] = ] unit-test +[ t ] [ [ { fixnum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test + +[ t ] [ [ { fixnum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test + +[ V{ integer } ] [ [ { fixnum } declare abs ] final-classes ] unit-test + +[ V{ integer } ] [ [ { fixnum } declare absq ] final-classes ] unit-test + +[ t ] [ [ { bignum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test + +[ t ] [ [ { bignum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test + [ t ] [ [ { float } declare abs ] final-info first interval>> [0,inf] = ] unit-test [ t ] [ [ { float } declare absq ] final-info first interval>> [0,inf] = ] unit-test @@ -247,6 +261,13 @@ IN: compiler.tree.propagation.tests ] final-literals ] unit-test +[ V{ 1.5 } ] [ + [ + /f + dup 1.5 u<= [ dup 1.5 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if + ] final-literals +] unit-test + [ V{ 1.5 } ] [ [ /f @@ -254,6 +275,13 @@ IN: compiler.tree.propagation.tests ] final-literals ] unit-test +[ V{ 1.5 } ] [ + [ + /f + dup 1.5 u<= [ dup 10 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if + ] final-literals +] unit-test + [ V{ f } ] [ [ /f @@ -261,6 +289,13 @@ IN: compiler.tree.propagation.tests ] final-literals ] unit-test +[ V{ f } ] [ + [ + /f + dup 0.0 u<= [ dup 0.0 u>= [ drop 0.0 ] unless ] [ drop 0.0 ] if + ] final-literals +] unit-test + [ V{ fixnum } ] [ [ 0 dup 10 > [ 100 * ] when ] final-classes ] unit-test @@ -269,6 +304,14 @@ IN: compiler.tree.propagation.tests [ 0 dup 10 > [ drop "foo" ] when ] final-classes ] unit-test +[ V{ fixnum } ] [ + [ 0 dup 10 u> [ 100 * ] when ] final-classes +] unit-test + +[ V{ fixnum } ] [ + [ 0 dup 10 u> [ drop "foo" ] when ] final-classes +] unit-test + [ V{ fixnum } ] [ [ { fixnum } declare 3 3 - + ] final-classes ] unit-test @@ -277,6 +320,10 @@ IN: compiler.tree.propagation.tests [ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals ] unit-test +[ V{ t } ] [ + [ dup 10 u< [ 3 * 30 u< ] [ drop t ] if ] final-literals +] unit-test + [ V{ "d" } ] [ [ 3 { @@ -300,10 +347,18 @@ IN: compiler.tree.propagation.tests [ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes ] unit-test +[ V{ fixnum } ] [ + [ >fixnum dup 100 u< [ 1 + ] [ "Oops" throw ] if ] final-classes +] unit-test + [ V{ -1 } ] [ [ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals ] unit-test +[ V{ -1 } ] [ + [ 0 dup 100 u< not [ 1 + ] [ 1 - ] if ] final-literals +] unit-test + [ V{ 2 } ] [ [ [ 1 ] [ 1 ] if 1 + ] final-literals ] unit-test @@ -312,12 +367,22 @@ IN: compiler.tree.propagation.tests [ 0 * 10 < ] final-classes ] unit-test +[ V{ object } ] [ + [ 0 * 10 u< ] final-classes +] unit-test + [ V{ 27 } ] [ [ 123 bitand dup 10 < over 8 > and [ 3 * ] [ "B" throw ] if ] final-literals ] unit-test +[ V{ 27 } ] [ + [ + 123 bitand dup 10 u< over 8 u> and [ 3 * ] [ "B" throw ] if + ] final-literals +] unit-test + [ V{ 27 } ] [ [ dup number? over sequence? and [ diff --git a/basis/math/floats/env/env-tests.factor b/basis/math/floats/env/env-tests.factor index a0ffa0713c..0c38d69ea9 100644 --- a/basis/math/floats/env/env-tests.factor +++ b/basis/math/floats/env/env-tests.factor @@ -1,5 +1,6 @@ USING: kernel math math.floats.env math.floats.env.private -math.functions math.libm sequences tools.test ; +math.functions math.libm sequences tools.test locals +compiler.units kernel.private fry compiler math.private words ; IN: math.floats.env.tests : set-default-fp-env ( -- ) @@ -8,45 +9,29 @@ IN: math.floats.env.tests ! In case the tests screw up the FP env because of bugs in math.floats.env set-default-fp-env -[ t ] [ - [ 1.0 0.0 / drop ] collect-fp-exceptions - +fp-zero-divide+ swap member? -] unit-test +: test-fp-exception ( exception inputs quot -- quot' ) + '[ _ [ @ @ ] collect-fp-exceptions nip member? ] ; -[ t ] [ - [ 1.0 3.0 / drop ] collect-fp-exceptions - +fp-inexact+ swap member? -] unit-test +: test-fp-exception-compiled ( exception inputs quot -- quot' ) + '[ _ @ [ _ collect-fp-exceptions ] compile-call nip member? ] ; -[ t ] [ - [ 1.0e250 1.0e100 * drop ] collect-fp-exceptions - +fp-overflow+ swap member? -] unit-test +[ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception unit-test +[ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception unit-test +[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception unit-test +[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception unit-test +[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception unit-test +[ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception unit-test +[ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception unit-test +[ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception unit-test -[ t ] [ - [ 1.0e-250 1.0e-100 * drop ] collect-fp-exceptions - +fp-underflow+ swap member? -] unit-test - -[ t ] [ - [ 2.0 100,000.0 ^ drop ] collect-fp-exceptions - +fp-overflow+ swap member? -] unit-test - -[ t ] [ - [ 2.0 -100,000.0 ^ drop ] collect-fp-exceptions - +fp-underflow+ swap member? -] unit-test - -[ t ] [ - [ 0.0 0.0 /f drop ] collect-fp-exceptions - +fp-invalid-operation+ swap member? -] unit-test - -[ t ] [ - [ -1.0 fsqrt drop ] collect-fp-exceptions - +fp-invalid-operation+ swap member? -] unit-test +[ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test +[ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception-compiled unit-test +[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception-compiled unit-test +[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception-compiled unit-test +[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test +[ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test +[ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test +[ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception-compiled unit-test [ HEX: 3fd5,5555,5555,5555 @@ -117,11 +102,72 @@ set-default-fp-env -1.0 3.0 /f double>bits ] unit-test -[ { +fp-zero-divide+ } [ 1.0 0.0 /f ] with-fp-traps ] must-fail -[ { +fp-inexact+ } [ 1.0 3.0 /f ] with-fp-traps ] must-fail -[ { +fp-invalid-operation+ } [ -1.0 fsqrt ] with-fp-traps ] must-fail -[ { +fp-overflow+ } [ 2.0 100,000.0 ^ ] with-fp-traps ] must-fail -[ { +fp-underflow+ } [ 2.0 -100,000.0 ^ ] with-fp-traps ] must-fail +: test-traps ( traps inputs quot -- quot' ) + append '[ _ _ with-fp-traps ] ; + +: test-traps-compiled ( traps inputs quot -- quot' ) + swapd '[ _ [ _ _ with-fp-traps ] compile-call ] ; + +{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail +{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail +{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail +{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail +{ +fp-underflow+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail + +{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail +{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail +{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail +{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail +{ +fp-underflow+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail + +! Ensure ordered comparisons raise traps +:: test-comparison-quot ( word -- quot ) + [ + { float float } declare + { +fp-invalid-operation+ } [ word execute ] with-fp-traps + ] ; + +: test-comparison ( inputs word -- quot ) + test-comparison-quot append ; + +: test-comparison-compiled ( inputs word -- quot ) + test-comparison-quot '[ @ _ compile-call ] ; + +\ float< "intrinsic" word-prop [ + [ 0/0. -15.0 ] \ < test-comparison must-fail + [ 0/0. -15.0 ] \ < test-comparison-compiled must-fail + [ -15.0 0/0. ] \ < test-comparison must-fail + [ -15.0 0/0. ] \ < test-comparison-compiled must-fail + [ 0/0. -15.0 ] \ <= test-comparison must-fail + [ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail + [ -15.0 0/0. ] \ <= test-comparison must-fail + [ -15.0 0/0. ] \ <= test-comparison-compiled must-fail + [ 0/0. -15.0 ] \ > test-comparison must-fail + [ 0/0. -15.0 ] \ > test-comparison-compiled must-fail + [ -15.0 0/0. ] \ > test-comparison must-fail + [ -15.0 0/0. ] \ > test-comparison-compiled must-fail + [ 0/0. -15.0 ] \ >= test-comparison must-fail + [ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail + [ -15.0 0/0. ] \ >= test-comparison must-fail + [ -15.0 0/0. ] \ >= test-comparison-compiled must-fail + + [ f ] [ 0/0. -15.0 ] \ u< test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u< test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled unit-test + [ f ] [ 0/0. -15.0 ] \ u<= test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u<= test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled unit-test + [ f ] [ 0/0. -15.0 ] \ u> test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u> test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled unit-test + [ f ] [ 0/0. -15.0 ] \ u>= test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u>= test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled unit-test +] when ! Ensure traps get cleared [ 1/0. ] [ 1.0 0.0 /f ] unit-test diff --git a/basis/math/floats/env/env.factor b/basis/math/floats/env/env.factor index 6a8110c4c1..ba198168da 100644 --- a/basis/math/floats/env/env.factor +++ b/basis/math/floats/env/env.factor @@ -102,7 +102,7 @@ PRIVATE> : clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline : collect-fp-exceptions ( quot -- exceptions ) - clear-fp-exception-flags call fp-exception-flags ; inline + [ clear-fp-exception-flags ] dip call fp-exception-flags ; inline : denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ; diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 6679e81fcd..7c66c911de 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -197,6 +197,12 @@ SYMBOL: fast-math-ops \ <= define-math-ops \ > define-math-ops \ >= define-math-ops + + \ u< define-math-ops + \ u<= define-math-ops + \ u> define-math-ops + \ u>= define-math-ops + \ number= define-math-ops { { shift bignum bignum } bignum-shift } , diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index ea8f6f5f49..0de957b785 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -455,12 +455,12 @@ M: bad-executable summary \ float/f { float float } { float } define-primitive \ float/f make-foldable -\ float< { float float } { object } define-primitive -\ float< make-foldable - \ float-mod { float float } { float } define-primitive \ float-mod make-foldable +\ float< { float float } { object } define-primitive +\ float< make-foldable + \ float<= { float float } { object } define-primitive \ float<= make-foldable @@ -470,6 +470,18 @@ M: bad-executable summary \ float>= { float float } { object } define-primitive \ float>= make-foldable +\ float-u< { float float } { object } define-primitive +\ float-u< make-foldable + +\ float-u<= { float float } { object } define-primitive +\ float-u<= make-foldable + +\ float-u> { float float } { object } define-primitive +\ float-u> make-foldable + +\ float-u>= { float float } { object } define-primitive +\ float-u>= make-foldable + \ { object object } { word } define-primitive \ make-flushable diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 13e17f90fd..355fa8ed58 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -409,6 +409,10 @@ tuple { "float<=" "math.private" (( x y -- ? )) } { "float>" "math.private" (( x y -- ? )) } { "float>=" "math.private" (( x y -- ? )) } + { "float-u<" "math.private" (( x y -- ? )) } + { "float-u<=" "math.private" (( x y -- ? )) } + { "float-u>" "math.private" (( x y -- ? )) } + { "float-u>=" "math.private" (( x y -- ? )) } { "" "words" (( name vocab -- word )) } { "word-xt" "words" (( word -- start end )) } { "getenv" "kernel.private" (( n -- obj )) } diff --git a/core/math/floats/floats-docs.factor b/core/math/floats/floats-docs.factor index ed4947e1f5..6e903a37e2 100644 --- a/core/math/floats/floats-docs.factor +++ b/core/math/floats/floats-docs.factor @@ -69,20 +69,54 @@ HELP: float> ( x y -- ? ) HELP: float>= ( x y -- ? ) { $values { "x" float } { "y" float } { "?" "a boolean" } } -{ $description "Primitive version of " { $link >= } "." } -{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link >= } " instead." } ; +{ $description "Primitive version of " { $link u>= } "." } +{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u>= } " instead." } ; -ARTICLE: "floats" "Floats" -{ $subsection float } -"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums." +HELP: float-u< ( x y -- ? ) +{ $values { "x" float } { "y" float } { "?" "a boolean" } } +{ $description "Primitive version of " { $link u< } "." } +{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u< } " instead." } ; + +HELP: float-u<= ( x y -- ? ) +{ $values { "x" float } { "y" float } { "?" "a boolean" } } +{ $description "Primitive version of " { $link u<= } "." } +{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u<= } " instead." } ; + +HELP: float-u> ( x y -- ? ) +{ $values { "x" float } { "y" float } { "?" "a boolean" } } +{ $description "Primitive version of " { $link u> } "." } +{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u> } " instead." } ; + +HELP: float-u>= ( x y -- ? ) +{ $values { "x" float } { "y" float } { "?" "a boolean" } } +{ $description "Primitive version of " { $link u>= } "." } +{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u>= } " instead." } ; + +ARTICLE: "math.floats.compare" "Floating point comparison operations" +"In mathematics, real numbers are linearly ordered; for any two numbers " { $snippet "a" } " and " { $snippet "b" } ", exactly one of the following is true:" +{ $code + "a < b" + "a = b" + "a > b" +} +"With floating point values, there is a fourth possibility; " { $snippet "a" } " and " { $snippet "b" } " may be " { $emphasis "unordered" } ". This happens if one or both values are Not-a-Number values." $nl -"Introducing a floating point number in a computation forces the result to be expressed in floating point." -{ $example "5/4 1/2 + ." "1+3/4" } -{ $example "5/4 0.5 + ." "1.75" } -"Integers and rationals can be converted to floats:" -{ $subsection >float } -"Two real numbers can be divided yielding a float result:" -{ $subsection /f } +"All comparison operators, including " { $link number= } ", return " { $link f } " in the unordered case (and in particular, this means that a NaN is not equal to itself)." +$nl +"The " { $emphasis "ordered" } " comparison operators set floating point exception flags if the result of the comparison is unordered. The standard comparison operators (" { $link < } ", " { $link <= } ", " { $link > } ", " { $link >= } ") perform ordered comparisons." +$nl +"The " { $link number= } " operation performs an unordered comparison. The following set of operators also perform unordered comparisons:" +{ $subsection u< } +{ $subsection u<= } +{ $subsection u> } +{ $subsection u>= } +"A word to check if two values are unordered with respect to each other:" +{ $subsection unordered? } +"To test for floating point exceptions, use the " { $vocab-link "math.floats.env" } " vocabulary." +$nl +"If neither input to a comparison operator is a floating point value, then " { $link u< } ", " { $link u<= } ", " { $link u> } " and " { $link u>= } " are equivalent to the ordered operators." ; + +ARTICLE: "math.floats.bitwise" "Bitwise operations on floats" "Floating point numbers are represented internally in IEEE 754 double-precision format. This internal representation can be accessed for advanced operations and input/output purposes." { $subsection float>bits } { $subsection double>bits } @@ -100,8 +134,25 @@ $nl { $subsection fp-snan? } { $subsection fp-infinity? } { $subsection fp-nan-payload } -"Comparing two floating point numbers:" +"Comparing two floating point numbers for bitwise equality:" { $subsection fp-bitwise= } -{ $see-also "syntax-floats" } ; +{ $see-also POSTPONE: NAN: } ; + +ARTICLE: "floats" "Floats" +{ $subsection float } +"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums." +$nl +"Introducing a floating point number in a computation forces the result to be expressed in floating point." +{ $example "5/4 1/2 + ." "1+3/4" } +{ $example "5/4 0.5 + ." "1.75" } +"Floating point literal syntax is documented in " { $link "syntax-floats" } "." +$nl +"Integers and rationals can be converted to floats:" +{ $subsection >float } +"Two real numbers can be divided yielding a float result:" +{ $subsection /f } +{ $subsection "math.floats.bitwise" } +{ $subsection "math.floats.compare" } +"The " { $vocab-link "math.floats.env" } " vocabulary provides functionality for controlling floating point exceptions, rounding modes, and denormal behavior." ; ABOUT: "floats" diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 9c49e99231..bc419b94c5 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -3,6 +3,7 @@ USING: kernel math math.private ; IN: math.floats.private +: float-unordered? ( x y -- ? ) [ fp-nan? ] bi@ or ; : float-min ( x y -- z ) [ float< ] most ; foldable : float-max ( x y -- z ) [ float> ] most ; foldable @@ -17,11 +18,17 @@ M: float hashcode* nip float>bits ; inline M: float equal? over float? [ float= ] [ 2drop f ] if ; inline M: float number= float= ; inline -M: float < float< ; inline +M: float < float< ; inline M: float <= float<= ; inline -M: float > float> ; inline +M: float > float> ; inline M: float >= float>= ; inline +M: float unordered? float-unordered? ; inline +M: float u< float-u< ; inline +M: float u<= float-u<= ; inline +M: float u> float-u> ; inline +M: float u>= float-u>= ; inline + M: float + float+ ; inline M: float - float- ; inline M: float * float* ; inline @@ -58,8 +65,6 @@ M: float next-float ] if ] if ; inline -M: float unordered? [ fp-nan? ] bi@ or ; inline - M: float prev-float double>bits dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index ed25e3bfa6..e684b8edfb 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -24,6 +24,11 @@ M: fixnum <= fixnum<= ; inline M: fixnum > fixnum> ; inline M: fixnum >= fixnum>= ; inline +M: fixnum u< fixnum< ; inline +M: fixnum u<= fixnum<= ; inline +M: fixnum u> fixnum> ; inline +M: fixnum u>= fixnum>= ; inline + M: fixnum + fixnum+ ; inline M: fixnum - fixnum- ; inline M: fixnum * fixnum* ; inline @@ -65,6 +70,11 @@ M: bignum <= bignum<= ; inline M: bignum > bignum> ; inline M: bignum >= bignum>= ; inline +M: bignum u< bignum< ; inline +M: bignum u<= bignum<= ; inline +M: bignum u> bignum> ; inline +M: bignum u>= bignum>= ; inline + M: bignum + bignum+ ; inline M: bignum - bignum- ; inline M: bignum * bignum* ; inline diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 97e0a1e7cf..e5de106bbb 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -5,7 +5,9 @@ IN: math HELP: number= { $values { "x" number } { "y" number } { "?" "a boolean" } } { $description "Tests if two numbers have the same numeric value." } -{ $notes "This word differs from " { $link = } " in that it disregards differences in type when comparing numbers." } +{ $notes "This word differs from " { $link = } " in that it disregards differences in type when comparing numbers." +$nl +"This word performs an unordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } { $examples { $example "USING: math prettyprint ;" "3.0 3 number= ." "t" } { $example "USING: kernel math prettyprint ;" "3.0 3 = ." "f" } @@ -13,20 +15,47 @@ HELP: number= HELP: < { $values { "x" real } { "y" real } { "?" boolean } } -{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } ; +{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } +{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ; HELP: <= { $values { "x" real } { "y" real } { "?" boolean } } -{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } ; +{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } +{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ; HELP: > { $values { "x" real } { "y" real } { "?" boolean } } -{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } ; +{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } +{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ; HELP: >= { $values { "x" real } { "y" real } { "?" boolean } } -{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ; +{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } +{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ; +HELP: unordered? +{ $values { "x" real } { "y" real } { "?" boolean } } +{ $description "Tests if " { $snippet "x" } " is unordered with respect to " { $snippet "y" } ". This can only occur if one or both values is a floating-point Not-a-Number value." } ; + +HELP: u< +{ $values { "x" real } { "y" real } { "?" boolean } } +{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } +{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link < } ". See " { $link "math.floats.compare" } " for an explanation." } ; + +HELP: u<= +{ $values { "x" real } { "y" real } { "?" boolean } } +{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } +{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link <= } ". See " { $link "math.floats.compare" } " for an explanation." } ; + +HELP: u> +{ $values { "x" real } { "y" real } { "?" boolean } } +{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } +{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link > } ". See " { $link "math.floats.compare" } " for an explanation." } ; + +HELP: u>= +{ $values { "x" real } { "y" real } { "?" boolean } } +{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } +{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link >= } ". See " { $link "math.floats.compare" } " for an explanation." } ; HELP: + { $values { "x" number } { "y" number } { "z" number } } @@ -328,6 +357,10 @@ HELP: fp-infinity? { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" } } ; +HELP: fp-sign +{ $values { "x" float } { "?" "a boolean" } } +{ $description "Outputs the sign bit of " { $snippet "x" } ". For ordered non-zero values, this is equivalent to calling " { $snippet "0 <" } ". For zero values, this outputs the zero's sign bit." } ; + HELP: fp-nan-payload { $values { "x" real } { "bits" integer } } { $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ; diff --git a/core/math/math.factor b/core/math/math.factor index 900c1e1cee..8ef4f38f9a 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2009 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math.private ; IN: math @@ -22,7 +22,12 @@ MATH: < ( x y -- ? ) foldable MATH: <= ( x y -- ? ) foldable MATH: > ( x y -- ? ) foldable MATH: >= ( x y -- ? ) foldable + MATH: unordered? ( x y -- ? ) foldable +MATH: u< ( x y -- ? ) foldable +MATH: u<= ( x y -- ? ) foldable +MATH: u> ( x y -- ? ) foldable +MATH: u>= ( x y -- ? ) foldable M: object unordered? 2drop f ; diff --git a/vm/primitives.cpp b/vm/primitives.cpp index 2359173d9b..6dbe281d0c 100644 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -51,6 +51,12 @@ const primitive_type primitives[] = { primitive_float_lesseq, primitive_float_greater, primitive_float_greatereq, + /* The unordered comparison primitives don't have a non-optimizing + compiler implementation */ + primitive_float_less, + primitive_float_lesseq, + primitive_float_greater, + primitive_float_greatereq, primitive_word, primitive_word_xt, primitive_getenv, From 3a61107f1dab168787a4ae41b9297022dba97810 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Sep 2009 22:30:11 -0500 Subject: [PATCH 2/7] typos in altivec env --- basis/math/floats/env/ppc/ppc.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/math/floats/env/ppc/ppc.factor b/basis/math/floats/env/ppc/ppc.factor index 748f149ccd..4ce3f0512e 100644 --- a/basis/math/floats/env/ppc/ppc.factor +++ b/basis/math/floats/env/ppc/ppc.factor @@ -90,7 +90,7 @@ M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' ) } case ] curry change-fpscr ; inline -CONSTANT: vmx-denormal-mode-bits HEX: 8000 +CONSTANT: vmx-denormal-mode-bits HEX: 10000 M: ppc-vmx-env (get-exception-flags) ( register -- exceptions ) drop { } ; inline @@ -109,7 +109,7 @@ M: ppc-vmx-env (set-rounding-mode) ( register mode -- register' ) M: ppc-vmx-env (get-denormal-mode) ( register -- mode ) vscr>> vmx-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline -M: ppc-vmx-env (get-denormal-mode) ( register mode -- register ) +M: ppc-vmx-env (set-denormal-mode) ( register mode -- register ) [ { { +denormal-keep+ [ vmx-denormal-mode-bits unmask ] } From 7b36689416819ca0bc290f5b0fa5341e7cc78c41 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Sep 2009 00:17:24 -0500 Subject: [PATCH 3/7] core-foundation.strings: fix load error --- basis/core-foundation/strings/strings.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor index 45f4460d13..4bbe050230 100644 --- a/basis/core-foundation/strings/strings.factor +++ b/basis/core-foundation/strings/strings.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.syntax alien.strings io.encodings.string kernel sequences byte-arrays io.encodings.utf8 math core-foundation -core-foundation.arrays destructors ; +core-foundation.arrays destructors parser fry alien words ; IN: core-foundation.strings TYPEDEF: void* CFStringRef From 4686063d0fe65a03d69f07e1b0d8b26b60aa3641 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Sep 2009 00:17:45 -0500 Subject: [PATCH 4/7] qtkit: add tags and authors --- extra/qtkit/authors.txt | 1 + extra/qtkit/tags.txt | 1 + 2 files changed, 2 insertions(+) create mode 100644 extra/qtkit/authors.txt create mode 100644 extra/qtkit/tags.txt diff --git a/extra/qtkit/authors.txt b/extra/qtkit/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/qtkit/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/qtkit/tags.txt b/extra/qtkit/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/qtkit/tags.txt @@ -0,0 +1 @@ +unportable From 4f094a7ce52c40a70061722a33d452d2c6cb57d8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 13 Sep 2009 00:21:57 -0500 Subject: [PATCH 5/7] fix bootstrap on openbsd --- basis/io/files/info/unix/openbsd/openbsd.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/files/info/unix/openbsd/openbsd.factor b/basis/io/files/info/unix/openbsd/openbsd.factor index fe94f70fd8..be88929f2e 100755 --- a/basis/io/files/info/unix/openbsd/openbsd.factor +++ b/basis/io/files/info/unix/openbsd/openbsd.factor @@ -6,7 +6,7 @@ sequences system unix unix.getfsstat.openbsd grouping unix.statfs.openbsd unix.statvfs.openbsd unix.types arrays io.files.info.unix classes.struct specialized-arrays io.encodings.utf8 ; -SPECIALIZED-ARRAY: statvfs +SPECIALIZED-ARRAY: statfs IN: io.files.unix.openbsd TUPLE: openbsd-file-system-info < unix-file-system-info From 16209bf68d1e38109ed403f7212e0b7dbf5bcb48 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Sep 2009 00:24:31 -0500 Subject: [PATCH 6/7] specialized-arrays: fix unit tests now that ALIEN: expects a hex literal --- basis/specialized-arrays/specialized-arrays-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index ebc21eec56..2698149bac 100755 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -100,12 +100,12 @@ SPECIALIZED-ARRAY: test-struct ] unit-test ! Regression -STRUCT: fixed-string { text char[100] } ; +STRUCT: fixed-string { text char[64] } ; SPECIALIZED-ARRAY: fixed-string -[ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [ - ALIEN: 123 4 [ (underlying)>> ] { } map-as +[ { ALIEN: 100 ALIEN: 140 ALIEN: 180 ALIEN: 1c0 } ] [ + ALIEN: 100 4 [ (underlying)>> ] { } map-as ] unit-test ! Ensure that byte-length works with direct arrays From 0d4845de2678121c81c3082884acfc2610925256 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Sep 2009 00:54:04 -0500 Subject: [PATCH 7/7] benchmark.gc1: reduce memory usage --- extra/benchmark/gc1/gc1.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/benchmark/gc1/gc1.factor b/extra/benchmark/gc1/gc1.factor index 8b0a3e6a43..da3b6bab66 100644 --- a/extra/benchmark/gc1/gc1.factor +++ b/extra/benchmark/gc1/gc1.factor @@ -3,6 +3,6 @@ USING: math sequences kernel ; IN: benchmark.gc1 -: gc1 ( -- ) 6000000 [ >bignum 1 + ] map drop ; +: gc1 ( -- ) 10 [ 600000 [ >bignum 1 + ] map drop ] times ; MAIN: gc1