diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index de612f2c28..d0b2cd4d9e 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -35,6 +35,8 @@ IN: compiler.cfg.hats : ^^shr-imm ( src1 src2 -- dst ) ^^r2 ##shr-imm ; inline : ^^sar ( src1 src2 -- dst ) ^^r2 ##sar ; inline : ^^sar-imm ( src1 src2 -- dst ) ^^r2 ##sar-imm ; inline +: ^^min ( src1 src2 -- dst ) ^^r2 ##min ; inline +: ^^max ( src1 src2 -- dst ) ^^r2 ##max ; inline : ^^not ( src -- dst ) ^^r1 ##not ; inline : ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline : ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 41e227ed76..9706507193 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -91,6 +91,8 @@ INSN: ##shr < ##binary ; INSN: ##shr-imm < ##binary-imm ; INSN: ##sar < ##binary ; INSN: ##sar-imm < ##binary-imm ; +INSN: ##min < ##binary ; +INSN: ##max < ##binary ; INSN: ##not < ##unary ; INSN: ##log2 < ##unary ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 17e8a1336d..562c3ad836 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -25,6 +25,9 @@ QUALIFIED: math.floats.private QUALIFIED: math.libm IN: compiler.cfg.intrinsics +: enable-intrinsics ( words -- ) + [ t "intrinsic" set-word-prop ] each ; + { kernel.private:tag kernel.private:getenv @@ -67,7 +70,7 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-signed-2 alien.accessors:alien-cell alien.accessors:set-alien-cell -} [ t "intrinsic" set-word-prop ] each +} enable-intrinsics : enable-alien-4-intrinsics ( -- ) { @@ -75,7 +78,7 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-unsigned-4 alien.accessors:alien-signed-4 alien.accessors:set-alien-signed-4 - } [ t "intrinsic" set-word-prop ] each ; + } enable-intrinsics ; : enable-float-intrinsics ( -- ) { @@ -94,7 +97,7 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-float alien.accessors:alien-double alien.accessors:set-alien-double - } [ t "intrinsic" set-word-prop ] each ; + } enable-intrinsics ; : enable-fsqrt ( -- ) \ math.libm:fsqrt t "intrinsic" set-word-prop ; @@ -103,10 +106,16 @@ IN: compiler.cfg.intrinsics { math.floats.private:float-min math.floats.private:float-max - } [ t "intrinsic" set-word-prop ] each ; + } enable-intrinsics ; + +: enable-min/max ( -- ) + { + math.integers.private:fixnum-min + math.integers.private:fixnum-max + } enable-intrinsics ; : enable-fixnum-log2 ( -- ) - \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ; + { math.integers.private:fixnum-log2 } enable-intrinsics ; : emit-intrinsic ( node word -- ) { @@ -130,6 +139,8 @@ IN: compiler.cfg.intrinsics { \ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] } { \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] } { \ kernel:eq? [ drop cc= emit-fixnum-comparison ] } + { \ math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] } + { \ math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] } { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] } { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] } { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] } diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index e8fc036020..15151ff9e6 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -35,6 +35,8 @@ UNION: two-operand-insn ##shr-imm ##sar ##sar-imm + ##min + ##max ##fixnum-overflow ##add-float ##sub-float diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 7c95c9d0a8..c0f793a7dc 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -149,6 +149,8 @@ M: ##shr generate-insn dst/src1/src2 %shr ; M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ; M: ##sar generate-insn dst/src1/src2 %sar ; M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ; +M: ##min generate-insn dst/src1/src2 %min ; +M: ##max generate-insn dst/src1/src2 %max ; M: ##not generate-insn dst/src %not ; M: ##log2 generate-insn dst/src %log2 ; diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 6180e49bef..23d26b0033 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -1,11 +1,10 @@ -USING: accessors arrays compiler.units kernel kernel.private math -math.constants math.private sequences strings tools.test words -continuations sequences.private hashtables.private byte-arrays -system random layouts vectors +USING: accessors arrays compiler.units kernel kernel.private +math math.constants math.private math.integers.private sequences +strings tools.test words continuations sequences.private +hashtables.private byte-arrays system random layouts vectors sbufs strings.private slots.private alien math.order alien.accessors alien.c-types alien.syntax alien.strings -namespaces libc io.encodings.ascii -classes compiler ; +namespaces libc io.encodings.ascii classes compiler ; IN: compiler.tests.intrinsics ! Make sure that intrinsic ops compile to correct code. @@ -271,6 +270,15 @@ cell 8 = [ [ 100000 swap array-nth ] compile-call ] unit-test +[ 2 ] [ 2 4 [ fixnum-min ] compile-call ] unit-test +[ 2 ] [ 4 2 [ fixnum-min ] compile-call ] unit-test +[ 4 ] [ 2 4 [ fixnum-max ] compile-call ] unit-test +[ 4 ] [ 4 2 [ fixnum-max ] compile-call ] unit-test +[ -2 ] [ -2 -4 [ fixnum-max ] compile-call ] unit-test +[ -2 ] [ -4 -2 [ fixnum-max ] compile-call ] unit-test +[ -4 ] [ -2 -4 [ fixnum-min ] compile-call ] unit-test +[ -4 ] [ -4 -2 [ fixnum-min ] compile-call ] unit-test + ! 64-bit overflow cell 8 = [ [ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index efcf05d7bc..69785c8c0a 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -79,11 +79,16 @@ IN: compiler.tree.propagation.known-words ] unless ; : ensure-math-class ( class must-be -- class' ) - [ class<= ] 2keep ? ; + [ class<= ] most ; : number-valued ( class interval -- class' interval' ) [ number ensure-math-class ] dip ; +: fixnum-valued ( class interval -- class' interval' ) + over null-class? [ + [ drop fixnum ] dip + ] unless ; + : integer-valued ( class interval -- class' interval' ) [ integer ensure-math-class ] dip ; @@ -304,7 +309,15 @@ flog fpow fsqrt facosh fasinh fatanh } [ { float } "default-output-classes" set-word-prop ] each -{ float-min float-max } [ - [ { float float } "input-classes" set-word-prop ] - [ { float } "default-output-classes" set-word-prop ] bi -] each +! Find a less repetitive way of doing this +\ float-min { float float } "input-classes" set-word-prop +\ float-min [ interval-min ] [ float-valued ] binary-op + +\ float-max { float float } "input-classes" set-word-prop +\ float-max [ interval-max ] [ float-valued ] binary-op + +\ fixnum-min { fixnum fixnum } "input-classes" set-word-prop +\ fixnum-min [ interval-min ] [ fixnum-valued ] binary-op + +\ fixnum-max { fixnum fixnum } "input-classes" set-word-prop +\ fixnum-max [ interval-max ] [ fixnum-valued ] binary-op diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index d0362b3222..9d0e5c8999 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences words fry generic accessors classes.tuple -classes classes.algebra definitions stack-checker.state quotations -classes.tuple.private math math.partial-dispatch math.private -math.intervals math.floats.private layouts math.order vectors hashtables -combinators effects generalizations assocs sets -combinators.short-circuit sequences.private locals +USING: kernel sequences words fry generic accessors +classes.tuple classes classes.algebra definitions +stack-checker.state quotations classes.tuple.private math +math.partial-dispatch math.private math.intervals +math.floats.private math.integers.private layouts math.order +vectors hashtables combinators effects generalizations assocs +sets combinators.short-circuit sequences.private locals stack-checker namespaces compiler.tree.propagation.info ; IN: compiler.tree.propagation.transforms @@ -79,15 +80,25 @@ IN: compiler.tree.propagation.transforms ] [ f ] if ] "custom-inlining" set-word-prop -{ - { min [ float-min ] } - { max [ float-max ] } -} [ - '[ - in-d>> first2 [ value-info class>> float class<= ] both? - [ _ ] [ f ] if - ] "custom-inlining" set-word-prop -] assoc-each +! Integrate this with generic arithmetic optimization instead? +: both-inputs? ( #call class -- ? ) + [ in-d>> first2 ] dip '[ value-info class>> _ class<= ] both? ; + +\ min [ + { + { [ dup fixnum both-inputs? ] [ [ fixnum-min ] ] } + { [ dup float both-inputs? ] [ [ float-min ] ] } + [ f ] + } cond nip +] "custom-inlining" set-word-prop + +\ max [ + { + { [ dup fixnum both-inputs? ] [ [ fixnum-max ] ] } + { [ dup float both-inputs? ] [ [ float-max ] ] } + [ f ] + } cond nip +] "custom-inlining" set-word-prop ! Generate more efficient code for common idiom \ clone [ diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 41cbd30146..fc972229e8 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -96,6 +96,8 @@ HOOK: %shr cpu ( dst src1 src2 -- ) HOOK: %shr-imm cpu ( dst src1 src2 -- ) HOOK: %sar cpu ( dst src1 src2 -- ) HOOK: %sar-imm cpu ( dst src1 src2 -- ) +HOOK: %min cpu ( dst src1 src2 -- ) +HOOK: %max cpu ( dst src1 src2 -- ) HOOK: %not cpu ( dst src -- ) HOOK: %log2 cpu ( dst src -- ) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 12414c3f94..da7b89de0b 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -123,6 +123,10 @@ M: x86 %xor-imm nip XOR ; M: x86 %shl-imm nip SHL ; M: x86 %shr-imm nip SHR ; M: x86 %sar-imm nip SAR ; + +M: x86 %min nip [ CMP ] [ CMOVG ] 2bi ; +M: x86 %max nip [ CMP ] [ CMOVL ] 2bi ; + M: x86 %not drop NOT ; M: x86 %log2 BSR ; @@ -579,3 +583,5 @@ M: x86 small-enough? ( n -- ? ) enable-float-intrinsics enable-fsqrt enable-float-min/max ; + +enable-min/max diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 4e44fc1208..1ee4e1e100 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -235,6 +235,10 @@ IN: math.intervals.tests interval-contains? ] unit-test +[ t ] [ full-interval 10 10 [a,b] interval-max 10 1/0. [a,b] = ] unit-test + +[ t ] [ full-interval 10 10 [a,b] interval-min -1/0. 10 [a,b] = ] unit-test + [ t ] [ 1 100 [a,b] -1 1 [a,b] interval/i [-inf,inf] = ] unit-test ! Accuracy of interval-mod diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 99997ab8cb..05f9906bb9 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -7,7 +7,7 @@ IN: math.intervals SYMBOL: empty-interval -SYMBOL: full-interval +SINGLETON: full-interval TUPLE: interval { from read-only } { to read-only } ; @@ -238,12 +238,24 @@ MEMO: array-capacity-interval ( -- interval ) ] do-empty-interval ; : interval-max ( i1 i2 -- i3 ) - #! Inaccurate; could be tighter - [ [ interval-closure ] bi@ [ max ] interval-op nan-not-ok ] do-empty-interval ; + { + { [ over empty-interval eq? ] [ drop ] } + { [ dup empty-interval eq? ] [ nip ] } + { [ 2dup [ full-interval eq? ] both? ] [ drop ] } + { [ over full-interval eq? ] [ nip from>> first [a,inf] ] } + { [ dup full-interval eq? ] [ drop from>> first [a,inf] ] } + [ [ interval-closure ] bi@ [ max ] interval-op nan-not-ok ] + } cond ; : interval-min ( i1 i2 -- i3 ) - #! Inaccurate; could be tighter - [ [ interval-closure ] bi@ [ min ] interval-op nan-not-ok ] do-empty-interval ; + { + { [ over empty-interval eq? ] [ drop ] } + { [ dup empty-interval eq? ] [ nip ] } + { [ 2dup [ full-interval eq? ] both? ] [ drop ] } + { [ over full-interval eq? ] [ nip to>> first [-inf,a] ] } + { [ dup full-interval eq? ] [ drop to>> first [-inf,a] ] } + [ [ interval-closure ] bi@ [ min ] interval-op nan-not-ok ] + } cond ; : interval-interior ( i1 -- i2 ) dup special-interval? [ diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 02dbd6ea84..53c3fe543e 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -3,8 +3,8 @@ USING: kernel math math.private ; IN: math.floats.private -: float-min ( x y -- z ) [ float< ] 2keep ? ; -: float-max ( x y -- z ) [ float> ] 2keep ? ; +: float-min ( x y -- z ) [ float< ] most ; foldable +: float-max ( x y -- z ) [ float> ] most ; foldable M: fixnum >float fixnum>float ; inline M: bignum >float bignum>float ; inline diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 75abd8087e..ed25e3bfa6 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -1,10 +1,13 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! Copyright (C) 2008, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private sequences sequences.private math math.private combinators ; IN: math.integers.private +: fixnum-min ( x y -- z ) [ fixnum< ] most ; foldable +: fixnum-max ( x y -- z ) [ fixnum> ] most ; foldable + M: integer numerator ; inline M: integer denominator drop 1 ; inline