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

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
+        init-literal-info
-        dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval
     ] [
         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>

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

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

basis/cpu/ppc/architecture/architecture.factor

@@ -18,13 +18,13 @@ IN: cpu.ppc.architecture
 : ds-reg 14 ; inline
 : rs-reg 15 ; inline
 
-: reserved-area-size
+: reserved-area-size ( -- n )
     os {
         { linux [ 2 ] }
         { macosx [ 6 ] }
     } case cells ; foldable
 
-: lr-save
+: lr-save ( -- n )
     os {
         { linux [ 1 ] }
         { macosx [ 2 ] }
@@ -32,12 +32,12 @@ IN: cpu.ppc.architecture
 
 : param@ ( n -- x ) reserved-area-size + ; inline
 
-: param-save-size 8 cells ; foldable
+: param-save-size ( -- n ) 8 cells ; foldable
 
 : local@ ( n -- x )
     reserved-area-size param-save-size + + ; inline
 
-: factor-area-size 2 cells ;
+: factor-area-size ( -- n ) 2 cells ; foldable
 
 : next-save ( n -- i ) cell - ;
 
@@ -96,9 +96,9 @@ M: ppc %epilogue ( n -- )
     1 1 rot ADDI
     0 MTLR ;
 
-: (%call) 11 MTLR BLRL ;
+: (%call) ( -- ) 11 MTLR BLRL ;
 
-: (%jump) 11 MTCTR BCTR ;
+: (%jump) ( -- ) 11 MTCTR BCTR ;
 
 : %load-dlsym ( symbol dll register -- )
     0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
@@ -218,7 +218,7 @@ M: ppc %box-long-long ( n func -- )
         4 1 rot cell + local@ LWZ
     ] when* r> f %alien-invoke ;
 
-: temp@ stack-frame* factor-area-size - swap - ;
+: temp@ ( m -- n ) stack-frame* factor-area-size - swap - ;
 
 : struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
 

basis/cpu/ppc/intrinsics/intrinsics.factor

@@ -11,17 +11,17 @@ math.floats.private classes slots.private combinators
 compiler.constants ;
 IN: cpu.ppc.intrinsics
 
-: %slot-literal-known-tag
+: %slot-literal-known-tag ( -- out value offset )
     "val" operand
     "obj" operand
     "n" get cells
     "obj" get operand-tag - ;
 
-: %slot-literal-any-tag
+: %slot-literal-any-tag ( -- out value offset )
     "obj" operand "scratch1" operand %untag
     "val" operand "scratch1" operand "n" get cells ;
 
-: %slot-any
+: %slot-any ( -- out value offset )
     "obj" operand "scratch1" operand %untag
     "offset" operand "n" operand 1 SRAWI
     "scratch1" operand "val" operand "offset" operand ;
@@ -188,7 +188,7 @@ IN: cpu.ppc.intrinsics
     }
 } define-intrinsics
 
-: generate-fixnum-mod
+: generate-fixnum-mod ( -- )
     #! PowerPC doesn't have a MOD instruction; so we compute
     #! x-(x/y)*y. Puts the result in "s" operand.
     "s" operand "r" operand "y" operand MULLW
@@ -259,7 +259,7 @@ IN: cpu.ppc.intrinsics
 \ fixnum+ \ ADD \ ADDO. overflow-template
 \ fixnum- \ SUBF \ SUBFO. overflow-template
 
-: generate-fixnum/i
+: generate-fixnum/i ( -- )
     #! This VOP is funny. If there is an overflow, it falls
     #! through to the end, and the result is in "x" operand.
     #! Otherwise it jumps to the "no-overflow" label and the
@@ -514,8 +514,8 @@ IN: cpu.ppc.intrinsics
 ! Alien intrinsics
 : %alien-accessor ( quot -- )
     "offset" operand dup %untag-fixnum
-    "offset" operand dup "alien" operand ADD
+    "scratch" operand "offset" operand "alien" operand ADD
-    "value" operand "offset" operand 0 roll call ; inline
+    "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" } }
     } ;
 

basis/ui/cocoa/cocoa.factor

@@ -44,29 +44,29 @@ M: pasteboard set-clipboard-contents
         dup install-window-delegate
         over -> release
         <handle>
-    ] keep set-world-handle ;
+    ] keep (>>handle) ;
 
 M: cocoa-ui-backend set-title ( string world -- )
-    world-handle window>> swap <NSString> -> setTitle: ;
+    handle>> window>> swap <NSString> -> setTitle: ;
 
 : enter-fullscreen ( world -- )
-    world-handle view>>
+    handle>> view>>
     NSScreen -> mainScreen
     f -> enterFullScreenMode:withOptions:
     drop ;
 
 : exit-fullscreen ( world -- )
-    world-handle view>> f -> exitFullScreenModeWithOptions: ;
+    handle>> view>> f -> exitFullScreenModeWithOptions: ;
 
 M: cocoa-ui-backend set-fullscreen* ( ? world -- )
     swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
 
 M: cocoa-ui-backend fullscreen* ( world -- ? )
-    world-handle view>> -> isInFullScreenMode zero? not ;
+    handle>> view>> -> isInFullScreenMode zero? not ;
 
 : auto-position ( world -- )
     dup window-loc>> { 0 0 } = [
-        world-handle window>> -> center
+        handle>> window>> -> center
     ] [
         drop
     ] if ;
@@ -74,20 +74,20 @@ M: cocoa-ui-backend fullscreen* ( world -- ? )
 M: cocoa-ui-backend (open-window) ( world -- )
     dup gadget-window
     dup auto-position
-    world-handle window>> f -> makeKeyAndOrderFront: ;
+    handle>> window>> f -> makeKeyAndOrderFront: ;
 
 M: cocoa-ui-backend (close-window) ( handle -- )
     window>> -> release ;
 
 M: cocoa-ui-backend close-window ( gadget -- )
     find-world [
-        world-handle [
+        handle>> [
             window>> f -> performClose:
         ] when*
     ] when* ;
 
 M: cocoa-ui-backend raise-window* ( world -- )
-    world-handle [
+    handle>> [
         window>> dup f -> orderFront: -> makeKeyWindow
         NSApp 1 -> activateIgnoringOtherApps:
     ] when* ;

basis/xml/writer/writer.factor

@@ -110,6 +110,9 @@ M: instruction write-item
         [ after>> write-chunk ]
     } cleave ;
 
+M: xml write-item
+    body>> write-item ;
+
 : print-xml ( xml -- )
     write-xml nl ;
 

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

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

extra/benchmark/mandel/mandel.factor

@@ -1,69 +1,45 @@
-USING: arrays io kernel math math.order namespaces sequences
+USING: arrays io kernel math math.functions math.order
-       byte-arrays byte-vectors math.functions math.parser io.files
+math.parser sequences locals byte-arrays byte-vectors io.files
-       colors.hsv io.encodings.binary ;
+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
+    dup 0 <= [ 2nip ] [
-    [ 2nip ] [ 1- >r sq dupd + r> iter ] if ; inline recursive
+        over absq 4.0 >= [ 2nip ] [
-
+            >r sq dupd + r> 1- iter
-SYMBOL: cols
+        ] 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 ]
-    x-inc * center real-part x-inc width 2 / * - + >float
+    [ y-inc * center imaginary-part y-inc height 2 / * - + >float ] bi*
-    r>
-    y-inc * center imaginary-part y-inc height 2 / * - + >float
     rect> ; inline
 
-: render ( -- )
+:: render ( accum -- )
     height [
         width swap [
-            c 0 nb-iter iter dup zero? [
+            c C{ 0.0 0.0 } nb-iter iter dup zero?
-                drop "\0\0\0"
+            [ drop B{ 0 0 0 } ] [ color-map [ length mod ] keep nth ] if
-            ] [
+            accum push-all
-                cols get [ length mod ] keep nth
-            ] if %
         ] curry each
-    ] each ;
+    ] each ; inline
 
-: ppm-header ( w h -- )
+:: ppm-header ( accum -- )
-    "P6\n" % swap # " " % # "\n255\n" % ;
+    "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>
-        buf-size <byte-vector> building set
+    [ ppm-header ] [ render ] [ B{ } like ] tri ;
-        width height ppm-header
-        nb-iter max-color min <color-map> cols set
-        render
-        building get >byte-array
-    ] with-scope ;
 
 : mandel-main ( -- )
     mandel "mandel.ppm" temp-file binary set-file-contents ;

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