From 669e0f8f0a9cf69b39b99916e74422ca4e6bdcb9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Sep 2008 18:25:21 -0500
Subject: [PATCH 1/7] Propagate slot types of literals
---
.../tree/propagation/info/info.factor | 34 +++++++++++++++++--
.../tree/propagation/propagation-tests.factor | 16 +++++++++
.../tree/propagation/slots/slots.factor | 6 ----
3 files changed, 47 insertions(+), 9 deletions(-)
diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index 2281c140a4..d0f418f3c9 100644
--- 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 503c633077..559a9bf60b 100644
--- 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 5e3480be2f..a4bd48ecc0 100644
--- 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> ;
From 9ca908e5a907d6dcc0996839c88f18bab068a1ee Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Sep 2008 18:26:10 -0500
Subject: [PATCH 2/7] Add some new byte array constructors
---
core/byte-arrays/byte-arrays.factor | 8 ++++++++
1 file changed, 8 insertions(+)
diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor
index 5461da2b84..0bcea2651a 100755
--- 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
From c26d2fb34515a5a1c8e309f3093c0c32ad47bb56 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Sep 2008 18:28:24 -0500
Subject: [PATCH 3/7] Clean up mandelbrot a bit
---
extra/benchmark/mandel/colors/colors.factor | 19 ++++++
extra/benchmark/mandel/mandel.factor | 74 +++++++--------------
extra/benchmark/mandel/params/params.factor | 8 +++
3 files changed, 52 insertions(+), 49 deletions(-)
create mode 100644 extra/benchmark/mandel/colors/colors.factor
create mode 100644 extra/benchmark/mandel/params/params.factor
diff --git a/extra/benchmark/mandel/colors/colors.factor b/extra/benchmark/mandel/colors/colors.factor
new file mode 100644
index 0000000000..848fbae01e
--- /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 2685ff28b7..a40b123ed3 100755
--- 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
index 0000000000..3fcfe1d3ef
--- /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
From 4be346cd9c563edac3b4198c0a4420421c666e80 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Sep 2008 18:34:16 -0500
Subject: [PATCH 4/7] Fixing PowerPC intrinsics
---
basis/cpu/ppc/intrinsics/intrinsics.factor | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/basis/cpu/ppc/intrinsics/intrinsics.factor b/basis/cpu/ppc/intrinsics/intrinsics.factor
index 6413cf839c..0109bbb26a 100755
--- 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" } }
} ;
From 36151938b381279628537fc92a36b2091618d97e Mon Sep 17 00:00:00 2001
From: dharmatech <dharmatech@goo.local>
Date: Mon, 1 Sep 2008 19:02:44 -0500
Subject: [PATCH 5/7] Update old accessors from 'ui.cocoa'
---
basis/ui/cocoa/cocoa.factor | 18 +++++++++---------
1 file changed, 9 insertions(+), 9 deletions(-)
diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor
index 40592cad30..1a05d23aa0 100755
--- a/basis/ui/cocoa/cocoa.factor
+++ b/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* ;
From c8cecf87687bb0d038deb2b24e41e2f8ed0d939f Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@oberon.local>
Date: Mon, 1 Sep 2008 19:06:00 -0500
Subject: [PATCH 6/7] Fix stack effect declarations
---
basis/cpu/ppc/architecture/architecture.factor | 14 +++++++-------
basis/cpu/ppc/intrinsics/intrinsics.factor | 10 +++++-----
2 files changed, 12 insertions(+), 12 deletions(-)
diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor
index 00bdb4b7c9..0aee836cf1 100755
--- a/basis/cpu/ppc/architecture/architecture.factor
+++ b/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 ;
diff --git a/basis/cpu/ppc/intrinsics/intrinsics.factor b/basis/cpu/ppc/intrinsics/intrinsics.factor
index 6413cf839c..7b77ce98de 100755
--- a/basis/cpu/ppc/intrinsics/intrinsics.factor
+++ b/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
From 6cff5eb76fcda8187f75d8d3398ae39a2319f262 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 1 Sep 2008 19:10:34 -0500
Subject: [PATCH 7/7] write-item writes parts of xml, so add a method on xml
objects to make it write their bodies without the prolog
---
basis/xml/writer/writer.factor | 3 +++
1 file changed, 3 insertions(+)
diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor
index 13f0be431c..8bda10102d 100644
--- a/basis/xml/writer/writer.factor
+++ b/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 ;