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

diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index 2281c140a4179babda5a3738588326b835aea8e0..d0f418f3c9834c16f963268c80ca68e618a7e674 100644 (file)
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -59,10 +59,38 @@ slots ;
 
 : <value-info> ( -- info ) \ value-info new ;
 
+: read-only-slots ( values class -- slots )
+    #! Delegation.
+    all-slots rest-slice
+    [ read-only>> [ drop f ] unless ] 2map
+    { f f } prepend ;
+
+DEFER: <literal-info>
+
+: init-literal-info ( info -- info )
+    #! Delegation.
+    dup literal>> class >>class
+    dup literal>> dup real? [ [a,a] >>interval ] [
+        [ [-inf,inf] >>interval ] dip
+        {
+            { [ dup complex? ] [
+                [ real-part <literal-info> ]
+                [ imaginary-part <literal-info> ] bi
+                2array >>slots
+            ] }
+            { [ dup tuple? ] [
+                [
+                    tuple-slots rest-slice
+                    [ <literal-info> ] map
+                ] [ class ] bi read-only-slots >>slots
+            ] }
+            [ drop ]
+        } cond
+    ] if ; inline
+
 : init-value-info ( info -- info )
     dup literal?>> [
-        dup literal>> class >>class
-        dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval
+        init-literal-info
     ] [
         dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [
             null >>class
@@ -73,7 +101,7 @@ slots ;
             dup [ class>> ] [ interval>> ] bi interval>literal
             [ >>literal ] [ >>literal? ] bi*
         ] if
-    ] if ;
+    ] if ; inline
 
 : <class/interval-info> ( class interval -- info )
     <value-info>

diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 503c6330777d9673613d8d6cbc9ab5ed811dcfe1..559a9bf60b6f652147d970ef8a3e63df5f19af20 100644 (file)
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -411,6 +411,14 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
     ] final-classes
 ] unit-test
 
+[ V{ integer array } ] [
+    [
+        [ 2drop T{ mixed-mutable-immutable f 3 { } } ]
+        [ { array } declare mixed-mutable-immutable boa ] if
+        [ x>> ] [ y>> ] bi
+    ] final-classes
+] unit-test
+
 ! Recursive propagation
 : recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
 
@@ -573,6 +581,14 @@ MIXIN: empty-mixin
 
 [ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test
 
+[ V{ float } ] [
+    [
+        [ { float float } declare <complex> ]
+        [ 2drop C{ 0.0 0.0 } ]
+        if real-part
+    ] final-classes
+] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test

diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor
index 5e3480be2fd183654d23d7a311c1674ec64d8826..a4bd48ecc00da049652c666e8b1195192c7ec269 100644 (file)
--- a/basis/compiler/tree/propagation/slots/slots.factor
+++ b/basis/compiler/tree/propagation/slots/slots.factor
@@ -31,12 +31,6 @@ UNION: fixed-length-sequence array byte-array string ;
 : tuple-constructor? ( word -- ? )
     { <tuple-boa> <complex> } memq? ;
 
-: read-only-slots ( values class -- slots )
-    #! Delegation.
-    all-slots rest-slice
-    [ read-only>> [ drop f ] unless ] 2map
-    { f f } prepend ;
-
 : fold-<tuple-boa> ( values class -- info )
     [ , f , [ literal>> ] map % ] { } make >tuple
     <literal-info> ;

diff --git a/basis/cpu/ppc/intrinsics/intrinsics.factor b/basis/cpu/ppc/intrinsics/intrinsics.factor
index 6413cf839ccbf7da8769afb611965b79fc60a1e3..0109bbb26aa2e9c7ee0184c94b23877950995efc 100755 (executable)
--- a/basis/cpu/ppc/intrinsics/intrinsics.factor
+++ b/basis/cpu/ppc/intrinsics/intrinsics.factor
@@ -514,8 +514,8 @@ IN: cpu.ppc.intrinsics
 ! Alien intrinsics
 : %alien-accessor ( quot -- )
     "offset" operand dup %untag-fixnum
-    "offset" operand dup "alien" operand ADD
-    "value" operand "offset" operand 0 roll call ; inline
+    "scratch" operand "offset" operand "alien" operand ADD
+    "value" operand "scratch" operand 0 roll call ; inline
 
 : alien-integer-get-template
     H{
@@ -539,6 +539,7 @@ IN: cpu.ppc.intrinsics
             { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
+        { +scratch+ { "scratch" } }
         { +clobber+ { "value" "offset" } }
     } ;
 

diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor
index 5461da2b84f307eb98af8c2697eb677e71a951d0..0bcea2651a8628d3cf84fc20e18b9e1ae011a5f6 100755 (executable)
--- a/core/byte-arrays/byte-arrays.factor
+++ b/core/byte-arrays/byte-arrays.factor
@@ -19,3 +19,11 @@ M: byte-array resize
     resize-byte-array ;
 
 INSTANCE: byte-array sequence
+
+: 1byte-array ( x -- array ) 1 <byte-array> [ set-first ] keep ; inline
+
+: 2byte-array ( x y -- array ) B{ } 2sequence ; inline
+
+: 3byte-array ( x y z -- array ) B{ } 3sequence ; inline
+
+: 4byte-array ( w x y z -- array ) B{ } 4sequence ; inline

diff --git a/extra/benchmark/mandel/colors/colors.factor b/extra/benchmark/mandel/colors/colors.factor
new file mode 100644 (file)
index 0000000..848fbae
--- /dev/null
+++ b/extra/benchmark/mandel/colors/colors.factor
@@ -0,0 +1,19 @@
+USING: math math.order kernel arrays byte-arrays sequences
+colors.hsv benchmark.mandel.params ;
+IN: benchmark.mandel.colors
+
+: scale 255 * >fixnum ; inline
+
+: scale-rgb ( r g b -- n ) [ scale ] tri@ 3byte-array ;
+
+: sat 0.85 ; inline
+: val 0.85 ; inline
+
+: <color-map> ( nb-cols -- map )
+    dup [
+        360 * swap 1+ / sat val
+        3array hsv>rgb first3 scale-rgb
+    ] with map ;
+
+: color-map ( -- map )
+    nb-iter max-color min <color-map> ; foldable

diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor
index 2685ff28b7c322c07efdbfa77951c218bccaedc9..a40b123ed302656cce27756f0b5ee59540d9dd4e 100755 (executable)
--- a/extra/benchmark/mandel/mandel.factor
+++ b/extra/benchmark/mandel/mandel.factor
@@ -1,69 +1,45 @@
-USING: arrays io kernel math math.order namespaces sequences
-       byte-arrays byte-vectors math.functions math.parser io.files
-       colors.hsv io.encodings.binary ;
-
+USING: arrays io kernel math math.functions math.order
+math.parser sequences locals byte-arrays byte-vectors io.files
+io.encodings.binary benchmark.mandel.params
+benchmark.mandel.colors ;
 IN: benchmark.mandel
 
-: max-color 360   ; inline
-: zoom-fact 0.8   ; inline
-: width     640   ; inline
-: height    480   ; inline
-: nb-iter   40    ; inline
-: center    -0.65 ; inline
-
-: scale 255 * >fixnum ; inline
-
-: scale-rgb ( r g b -- n ) [ scale ] tri@ 3array ;
-
-: sat 0.85 ; inline
-: val 0.85 ; inline
-
-: <color-map> ( nb-cols -- map )
-    dup [
-        360 * swap 1+ / sat val
-        3array hsv>rgb first3 scale-rgb
-    ] with map ;
-
 : iter ( c z nb-iter -- x )
-    over absq 4.0 >= over zero? or
-    [ 2nip ] [ 1- >r sq dupd + r> iter ] if ; inline recursive
-
-SYMBOL: cols
+    dup 0 <= [ 2nip ] [
+        over absq 4.0 >= [ 2nip ] [
+            >r sq dupd + r> 1- iter
+        ] if
+    ] if ; inline recursive
 
 : x-inc width  200000 zoom-fact * / ; inline
 : y-inc height 150000 zoom-fact * / ; inline
 
 : c ( i j -- c )
-    >r
-    x-inc * center real-part x-inc width 2 / * - + >float
-    r>
-    y-inc * center imaginary-part y-inc height 2 / * - + >float
+    [ x-inc * center real-part x-inc width 2 / * - + >float ]
+    [ y-inc * center imaginary-part y-inc height 2 / * - + >float ] bi*
     rect> ; inline
 
-: render ( -- )
+:: render ( accum -- )
     height [
         width swap [
-            c 0 nb-iter iter dup zero? [
-                drop "\0\0\0"
-            ] [
-                cols get [ length mod ] keep nth
-            ] if %
+            c C{ 0.0 0.0 } nb-iter iter dup zero?
+            [ drop B{ 0 0 0 } ] [ color-map [ length mod ] keep nth ] if
+            accum push-all
         ] curry each
-    ] each ;
+    ] each ; inline
 
-: ppm-header ( w h -- )
-    "P6\n" % swap # " " % # "\n255\n" % ;
+:: ppm-header ( accum -- )
+    "P6\n" accum push-all
+    width number>string accum push-all
+    " " accum push-all
+    height number>string accum push-all
+    "\n255\n" accum push-all ; inline
 
-: buf-size ( -- n ) width height * 3 * 100 + ;
+: buf-size ( -- n ) width height * 3 * 100 + ; inline
 
 : mandel ( -- data )
-    [
-        buf-size <byte-vector> building set
-        width height ppm-header
-        nb-iter max-color min <color-map> cols set
-        render
-        building get >byte-array
-    ] with-scope ;
+    buf-size <byte-vector>
+    [ ppm-header ] [ render ] [ B{ } like ] tri ;
 
 : mandel-main ( -- )
     mandel "mandel.ppm" temp-file binary set-file-contents ;

diff --git a/extra/benchmark/mandel/params/params.factor b/extra/benchmark/mandel/params/params.factor
new file mode 100644 (file)
index 0000000..3fcfe1d
--- /dev/null
+++ b/extra/benchmark/mandel/params/params.factor
@@ -0,0 +1,8 @@
+IN: benchmark.mandel.params
+
+: max-color 360   ; inline
+: zoom-fact 0.8   ; inline
+: width     640   ; inline
+: height    480   ; inline
+: nb-iter   40    ; inline
+: center    -0.65 ; inline