Merge branch 'master' of git://factorcode.org/git/factor

basis/alien/arrays/arrays.factor

@@ -8,6 +8,8 @@ UNION: value-type array struct-type ;
 
 M: array c-type ;
 
+M: array c-type-class drop object ;
+
 M: array heap-size unclip heap-size [ * ] reduce ;
 
 M: array c-type-align first c-type-align ;

basis/alien/c-types/c-types.factor

@@ -13,13 +13,15 @@ DEFER: *char
 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
 
 TUPLE: c-type
+class
 boxer boxer-quot unboxer unboxer-quot
 getter setter
 reg-class size align stack-align? ;
 
 : new-c-type ( class -- type )
     new
-        int-regs >>reg-class ;
+        int-regs >>reg-class
+        object >>class ;
 
 : <c-type> ( -- type )
     \ c-type new-c-type ;
@@ -63,6 +65,12 @@ M: string c-type ( name -- type )
         ] ?if
     ] if ;
 
+GENERIC: c-type-class ( name -- class )
+
+M: c-type c-type-class class>> ;
+
+M: string c-type-class c-type c-type-class ;
+
 GENERIC: c-type-boxer ( name -- boxer )
 
 M: c-type c-type-boxer boxer>> ;
@@ -306,6 +314,7 @@ M: long-long-type box-return ( type -- )
 
 [
     <c-type>
+        c-ptr >>class
         [ alien-cell ] >>getter
         [ set-alien-cell ] >>setter
         bootstrap-cell >>size
@@ -315,6 +324,7 @@ M: long-long-type box-return ( type -- )
     "void*" define-primitive-type
 
     <long-long-type>
+        integer >>class
         [ alien-signed-8 ] >>getter
         [ set-alien-signed-8 ] >>setter
         8 >>size
@@ -324,6 +334,7 @@ M: long-long-type box-return ( type -- )
     "longlong" define-primitive-type
 
     <long-long-type>
+        integer >>class
         [ alien-unsigned-8 ] >>getter
         [ set-alien-unsigned-8 ] >>setter
         8 >>size
@@ -333,6 +344,7 @@ M: long-long-type box-return ( type -- )
     "ulonglong" define-primitive-type
 
     <c-type>
+        integer >>class
         [ alien-signed-cell ] >>getter
         [ set-alien-signed-cell ] >>setter
         bootstrap-cell >>size
@@ -342,6 +354,7 @@ M: long-long-type box-return ( type -- )
     "long" define-primitive-type
 
     <c-type>
+        integer >>class
         [ alien-unsigned-cell ] >>getter
         [ set-alien-unsigned-cell ] >>setter
         bootstrap-cell >>size
@@ -351,6 +364,7 @@ M: long-long-type box-return ( type -- )
     "ulong" define-primitive-type
 
     <c-type>
+        integer >>class
         [ alien-signed-4 ] >>getter
         [ set-alien-signed-4 ] >>setter
         4 >>size
@@ -360,6 +374,7 @@ M: long-long-type box-return ( type -- )
     "int" define-primitive-type
 
     <c-type>
+        integer >>class
         [ alien-unsigned-4 ] >>getter
         [ set-alien-unsigned-4 ] >>setter
         4 >>size
@@ -369,6 +384,7 @@ M: long-long-type box-return ( type -- )
     "uint" define-primitive-type
 
     <c-type>
+        fixnum >>class
         [ alien-signed-2 ] >>getter
         [ set-alien-signed-2 ] >>setter
         2 >>size
@@ -378,6 +394,7 @@ M: long-long-type box-return ( type -- )
     "short" define-primitive-type
 
     <c-type>
+        fixnum >>class
         [ alien-unsigned-2 ] >>getter
         [ set-alien-unsigned-2 ] >>setter
         2 >>size
@@ -387,6 +404,7 @@ M: long-long-type box-return ( type -- )
     "ushort" define-primitive-type
 
     <c-type>
+        fixnum >>class
         [ alien-signed-1 ] >>getter
         [ set-alien-signed-1 ] >>setter
         1 >>size
@@ -396,6 +414,7 @@ M: long-long-type box-return ( type -- )
     "char" define-primitive-type
 
     <c-type>
+        fixnum >>class
         [ alien-unsigned-1 ] >>getter
         [ set-alien-unsigned-1 ] >>setter
         1 >>size
@@ -414,6 +433,7 @@ M: long-long-type box-return ( type -- )
     "bool" define-primitive-type
 
     <c-type>
+        float >>class
         [ alien-float ] >>getter
         [ [ >float ] 2dip set-alien-float ] >>setter
         4 >>size
@@ -425,6 +445,7 @@ M: long-long-type box-return ( type -- )
     "float" define-primitive-type
 
     <c-type>
+        float >>class
         [ alien-double ] >>getter
         [ [ >float ] 2dip set-alien-double ] >>setter
         8 >>size

basis/alien/strings/strings.factor

@@ -40,6 +40,9 @@ PREDICATE: string-type < pair
 
 M: string-type c-type ;
 
+M: string-type c-type-class
+    drop object ;
+
 M: string-type heap-size
     drop "void*" heap-size ;
 

basis/alien/structs/structs.factor

@@ -9,6 +9,8 @@ TUPLE: struct-type size align fields ;
 
 M: struct-type heap-size size>> ;
 
+M: struct-type c-type-class drop object ;
+
 M: struct-type c-type-align align>> ;
 
 M: struct-type c-type-stack-align? drop f ;

basis/compiler/cfg/builder/builder.factor

@@ -260,7 +260,7 @@ M: #terminate emit-node drop stop-iterating ;
 
 : emit-alien-node ( node quot -- next )
     [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
-    begin-basic-block iterate-next ; inline
+    ##branch begin-basic-block iterate-next ; inline
 
 M: #alien-invoke emit-node
     [ ##alien-invoke ] emit-alien-node ;

basis/compiler/tests/codegen.factor

@@ -262,5 +262,17 @@ TUPLE: id obj ;
 [ 3 ] [ 1 t fixnum-overflow-control-flow-test ] unit-test
 [ 2 ] [ 1 f fixnum-overflow-control-flow-test ] unit-test
 
+! LOL
+: blah ( a -- b )
+    { float } declare dup 0 =
+    [ drop 1 ] [
+        dup 0 >=
+        [ 2 "double" "libm" "pow" { "double" "double" } alien-invoke ]
+        [ -0.5 "double" "libm" "pow" { "double" "double" } alien-invoke ]
+        if
+    ] if ;
+
+[ 4.0 ] [ 2.0 blah ] unit-test
+
 [ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test
 [ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -37,31 +37,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
 
 \ bitnot { integer } "input-classes" set-word-prop
 
-{
-    fcosh
-    flog
-    fsinh
-    fexp
-    fasin
-    facosh
-    fasinh
-    ftanh
-    fatanh
-    facos
-    fpow
-    fatan
-    fatan2
-    fcos
-    ftan
-    fsin
-    fsqrt
-} [
-    dup stack-effect
-    [ in>> length real <repetition> "input-classes" set-word-prop ]
-    [ out>> length float <repetition> "default-output-classes" set-word-prop ]
-    2bi
-] each
-
 : ?change-interval ( info quot -- quot' )
     over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
 
@@ -222,8 +197,15 @@ generic-comparison-ops [
 
 {
     { >fixnum fixnum }
+    { bignum>fixnum fixnum }
+
     { >bignum bignum }
+    { fixnum>bignum bignum }
+    { float>bignum bignum }
+
     { >float float }
+    { fixnum>float float }
+    { bignum>float float }
 } [
     '[
         _

basis/compiler/tree/propagation/propagation-tests.factor

@@ -8,7 +8,7 @@ math.functions math.private strings layouts
 compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
-float-arrays system sorting ;
+float-arrays system sorting math.libm ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
@@ -594,6 +594,10 @@ MIXIN: empty-mixin
 
 [ V{ array } ] [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test
 
+[ V{ float } ] [ [ fsqrt ] final-classes ] unit-test
+
+[ V{ t } ] [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test

basis/compiler/tree/propagation/simple/simple.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors kernel sequences sequences.private assocs words
 namespaces classes.algebra combinators classes classes.tuple
-classes.tuple.private continuations arrays
+classes.tuple.private continuations arrays alien.c-types
 math math.private slots generic definitions
 stack-checker.state
 compiler.tree
@@ -137,11 +137,12 @@ M: #call propagate-after
     dup word>> "input-classes" word-prop dup
     [ propagate-input-classes ] [ 2drop ] if ;
 
-M: #alien-invoke propagate-before
+: propagate-alien-invoke ( node -- )
-    out-d>> [ object-info swap set-value-info ] each ;
+    [ out-d>> ] [ params>> return>> ] bi
+    [ drop ] [ c-type-class <class-info> swap first set-value-info ] if-void ;
 
-M: #alien-indirect propagate-before
+M: #alien-invoke propagate-before propagate-alien-invoke ;
-    out-d>> [ object-info swap set-value-info ] each ;
 
-M: #return annotate-node
+M: #alien-indirect propagate-before propagate-alien-invoke ;
-    dup in-d>> (annotate-node) ;
+
+M: #return annotate-node dup in-d>> (annotate-node) ;

basis/math/functions/functions.factor

@@ -100,7 +100,7 @@ PRIVATE>
         { [ dup integer? ] [ integer^ ] }
         { [ 2dup real^? ] [ fpow ] }
         [ ^complex ]
-    } cond ;
+    } cond ; inline
 
 : (^mod) ( n x y -- z )
     1 swap [
@@ -174,47 +174,61 @@ M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ;
 
 M: complex log >polar swap flog swap rect> ;
 
-: cos ( x -- y )
+GENERIC: cos ( x -- y ) foldable
-    dup complex? [
+
+M: complex cos
     >float-rect 2dup
     fcosh swap fcos * -rot
-        fsinh swap fsin neg * rect>
+    fsinh swap fsin neg * rect> ;
-    ] [ fcos ] if ; foldable
+
+M: real cos fcos ;
 
 : sec ( x -- y ) cos recip ; inline
 
-: cosh ( x -- y )
+GENERIC: cosh ( x -- y ) foldable
-    dup complex? [
+
+M: complex cosh
     >float-rect 2dup
     fcos swap fcosh * -rot
-        fsin swap fsinh * rect>
+    fsin swap fsinh * rect> ;
-    ] [ fcosh ] if ; foldable
+
+M: real cosh fcosh ;
 
 : sech ( x -- y ) cosh recip ; inline
 
-: sin ( x -- y )
+GENERIC: sin ( x -- y ) foldable
-    dup complex? [
+
+M: complex sin
     >float-rect 2dup
     fcosh swap fsin * -rot
-        fsinh swap fcos * rect>
+    fsinh swap fcos * rect> ;
-    ] [ fsin ] if ; foldable
+
+M: real sin fsin ;
 
 : cosec ( x -- y ) sin recip ; inline
 
-: sinh ( x -- y )
+GENERIC: sinh ( x -- y ) foldable
-    dup complex? [
+
+M: complex sinh 
     >float-rect 2dup
     fcos swap fsinh * -rot
-        fsin swap fcosh * rect>
+    fsin swap fcosh * rect> ;
-    ] [ fsinh ] if ; foldable
+
+M: real sinh fsinh ;
 
 : cosech ( x -- y ) sinh recip ; inline
 
-: tan ( x -- y )
+GENERIC: tan ( x -- y ) foldable
-    dup complex? [ dup sin swap cos / ] [ ftan ] if ; inline
 
-: tanh ( x -- y )
+M: complex tan [ sin ] [ cos ] bi / ;
-    dup complex? [ dup sinh swap cosh / ] [ ftanh ] if ; inline
+
+M: real tan ftan ;
+
+GENERIC: tanh ( x -- y ) foldable
+
+M: complex tanh [ sinh ] [ cosh ] bi / ;
+
+M: real tanh ftanh ;
 
 : cot ( x -- y ) tan recip ; inline
 
@@ -231,7 +245,7 @@ M: complex log >polar swap flog swap rect> ;
 : acosech ( x -- y ) recip asinh ; inline
 
 : atanh ( x -- y )
-    dup 1+ swap 1- neg / log 2 / ; inline
+    [ 1+ ] [ 1- neg ] bi / log 2 / ; inline
 
 : acoth ( x -- y ) recip atanh ; inline
 
@@ -246,8 +260,11 @@ M: complex log >polar swap flog swap rect> ;
     dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ;
     inline
 
-: atan ( x -- y )
+GENERIC: atan ( x -- y ) foldable
-    dup complex? [ i* atanh i* ] [ fatan ] if ; inline
+
+M: complex atan i* atanh i* ;
+
+M: real atan fatan ;
 
 : asec ( x -- y ) recip acos ; inline
 

basis/math/libm/libm.factor

@@ -5,69 +5,69 @@ IN: math.libm
 
 : facos ( x -- y )
     "double" "libm" "acos" { "double" } alien-invoke ;
-    foldable
+    inline
 
 : fasin ( x -- y )
     "double" "libm" "asin" { "double" } alien-invoke ;
-    foldable
+    inline
 
 : fatan ( x -- y )
     "double" "libm" "atan" { "double" } alien-invoke ;
-    foldable
+    inline
 
 : fatan2 ( x y -- z )
     "double" "libm" "atan2" { "double" "double" } alien-invoke ;
-    foldable
+    inline
 
 : fcos ( x -- y )
     "double" "libm" "cos" { "double" } alien-invoke ;
-    foldable
+    inline
 
 : fsin ( x -- y )
     "double" "libm" "sin" { "double" } alien-invoke ;
-    foldable
+    inline
 
 : ftan ( x -- y )
     "double" "libm" "tan" { "double" } alien-invoke ;
-    foldable
+    inline
 
 : fcosh ( x -- y )
     "double" "libm" "cosh" { "double" } alien-invoke ;
-    foldable
+    inline
 
 : fsinh ( x -- y )
     "double" "libm" "sinh" { "double" } alien-invoke ;
-    foldable
+    inline
 
 : ftanh ( x -- y )
     "double" "libm" "tanh" { "double" } alien-invoke ;
-    foldable
+    inline
 
 : fexp ( x -- y )
     "double" "libm" "exp" { "double" } alien-invoke ;
-    foldable
+    inline
 
 : flog ( x -- y )
     "double" "libm" "log" { "double" } alien-invoke ;
-    foldable
+    inline
 
 : fpow ( x y -- z )
     "double" "libm" "pow" { "double" "double" } alien-invoke ;
-    foldable
+    inline
 
 : fsqrt ( x -- y )
     "double" "libm" "sqrt" { "double" } alien-invoke ;
-    foldable
+    inline
     
 ! Windows doesn't have these...
 : facosh ( x -- y )
     "double" "libm" "acosh" { "double" } alien-invoke ;
-    foldable
+    inline
 
 : fasinh ( x -- y )
     "double" "libm" "asinh" { "double" } alien-invoke ;
-    foldable
+    inline
 
 : fatanh ( x -- y )
     "double" "libm" "atanh" { "double" } alien-invoke ;
-    foldable
+    inline

basis/math/ranges/ranges.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel layouts math math.order namespaces sequences
 sequences.private accessors ;
 IN: math.ranges
@@ -8,9 +10,7 @@ TUPLE: range
 { step read-only } ;
 
 : <range> ( a b step -- range )
-    [ over - ] dip
+    [ over - ] dip [ /i 1+ 0 max ] keep range boa ; inline
-    [ / 1+ 0 max >integer ] keep
-    range boa ; inline
 
 M: range length ( seq -- n )
     length>> ;

extra/benchmark/partial-sums/partial-sums.factor

@@ -1,63 +1,44 @@
-USING: math math.functions kernel sequences io io.styles
+! Copyright (C) 2008 Slava Pestov.
-prettyprint words hints ;
+! See http://factorcode.org/license.txt for BSD license.
+USING: math math.functions kernel io io.styles prettyprint
+combinators hints fry namespaces sequences ;
 IN: benchmark.partial-sums
 
-: summing ( n quot -- y )
+! Helper words
-    [ >float ] swap [ + ] 3compose
+: summing-integers ( n quot -- y ) [ 0.0 ] 2dip '[ 1+ @ + ] each ; inline
-    0.0 -rot 1 -rot (each-integer) ; inline
+: summing-floats ( n quot -- y ) '[ >float @ ] summing-integers ; inline
-
-: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1- ^ ] summing ;
-
-HINTS: 2/3^k fixnum ;
-
-: k^-0.5 ( n -- y ) [ -0.5 ^ ] summing ;
-
-HINTS: k^-0.5 fixnum ;
-
-: 1/k(k+1) ( n -- y ) [ dup 1+ * recip ] summing ;
-
-HINTS: 1/k(k+1) fixnum ;
-
 : cube ( x -- y ) dup dup * * ; inline
+: -1^ ( n -- -1/1 ) 2 mod 2 * 1- ; inline
 
-: flint-hills ( n -- y )
+! The functions
-    [ dup cube swap sin sq * recip ] summing ;
+: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1- ^ ] summing-floats ; inline
+: k^-0.5 ( n -- y ) [ -0.5 ^ ] summing-floats ; inline
+: 1/k(k+1) ( n -- y ) [ dup 1+ * recip ] summing-floats ; inline
+: flint-hills ( n -- y ) [ [ cube ] [ sin sq ] bi * recip ] summing-floats ; inline
+: cookson-hills ( n -- y ) [ [ cube ] [ cos sq ] bi * recip ] summing-floats ; inline
+: harmonic ( n -- y ) [ recip ] summing-floats ; inline
+: riemann-zeta ( n -- y ) [ sq recip ] summing-floats ; inline
+: alternating-harmonic ( n -- y ) [ [ -1^ ] keep /f ] summing-integers ; inline
+: gregory ( n -- y ) [ [ -1^ ] [ 2.0 * 1- ] bi / ] summing-integers ; inline
 
-HINTS: flint-hills fixnum ;
+: partial-sums ( n -- results )
+    [
+        {
+            [ 2/3^k                 \ 2/3^k                set ]
+            [ k^-0.5                \ k^-0.5               set ]
+            [ 1/k(k+1)              \ 1/k(k+1)             set ]
+            [ flint-hills           \ flint-hills          set ]
+            [ cookson-hills         \ cookson-hills        set ]
+            [ harmonic              \ harmonic             set ]
+            [ riemann-zeta          \ riemann-zeta         set ]
+            [ alternating-harmonic  \ alternating-harmonic set ]
+            [ gregory               \ gregory              set ]
+        } cleave
+    ] { } make-assoc ;
 
-: cookson-hills ( n -- y )
+HINTS: partial-sums fixnum ;
-    [ dup cube swap cos sq * recip ] summing ;
 
-HINTS: cookson-hills fixnum ;
+: partial-sums-main ( -- )
-
+    2500000 partial-sums simple-table. ;
-: harmonic ( n -- y ) [ recip ] summing ;
-
-HINTS: harmonic fixnum ;
-
-: riemann-zeta ( n -- y ) [ sq recip ] summing ;
-
-HINTS: riemann-zeta fixnum ;
-
-: -1^ 2 mod zero? 1 -1 ? ; inline
-
-: alternating-harmonic ( n -- y ) [ dup -1^ swap / ] summing ;
-
-HINTS: alternating-harmonic fixnum ;
-
-: gregory ( n -- y ) [ dup -1^ swap 2 * 1- / ] summing ;
-
-HINTS: gregory fixnum ;
-
-: functions
-    { 2/3^k k^-0.5 1/k(k+1) flint-hills cookson-hills harmonic riemann-zeta alternating-harmonic gregory } ;
-
-: partial-sums ( n -- )
-    standard-table-style [
-        functions [
-            [ tuck execute pprint-cell pprint-cell ] with-row
-        ] with each
-    ] tabular-output ;
-
-: partial-sums-main ( -- ) 2500000 partial-sums ;
 
 MAIN: partial-sums-main