From ee6443053bbdac17785f6c074a5de446365cd3bf Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 6 Jul 2008 19:39:53 -0700
Subject: [PATCH 01/14] Remove useless bitand from integer>bit-array;
set-alien-unsigned-1 does that for us!
---
extra/bit-arrays/bit-arrays.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/bit-arrays/bit-arrays.factor b/extra/bit-arrays/bit-arrays.factor
index 3d699a2623..4e6f7428b0 100755
--- a/extra/bit-arrays/bit-arrays.factor
+++ b/extra/bit-arrays/bit-arrays.factor
@@ -76,7 +76,7 @@ M: bit-array byte-length length 7 + -3 shift ;
n zero? [ 0 <bit-array> ] [
[let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
[ n' zero? not ] [
- n' out underlying>> i 255 bitand set-alien-unsigned-1
+ n' out underlying>> i set-alien-unsigned-1
n' -8 shift n'!
i 1+ i!
] [ ] while
From 2f560ffbe0ac1dc1eaad61774698b7b80ba91c0f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 11 Jul 2008 17:46:57 -0500
Subject: [PATCH 02/14] Fix typo
---
core/classes/tuple/tuple-docs.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 114146e450..51c175a282 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -298,16 +298,16 @@ $nl
"For example, compare the definitions of the " { $link sbuf } " class,"
{ $code
"TUPLE: sbuf"
- "{ \"underlying\" string }"
- "{ \"length\" array-capacity } ;"
+ "{ underlying string }"
+ "{ length array-capacity } ;"
""
"INSTANCE: sbuf growable"
}
"with that of the " { $link vector } " class:"
{ $code
"TUPLE: vector"
- "{ \"underlying\" array }"
- "{ \"length\" array-capacity } ;"
+ "{ underlying array }"
+ "{ length array-capacity } ;"
""
"INSTANCE: vector growable"
} ;
From 610d38720ab1d9fa8ff9c565131e50ddb75299d6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 11 Jul 2008 20:05:32 -0500
Subject: [PATCH 03/14] Improve optimized-quot.
---
extra/optimizer/debugger/debugger.factor | 30 ++++++++++++++----------
1 file changed, 17 insertions(+), 13 deletions(-)
diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor
index e3740f9cba..c20685cf70 100755
--- a/extra/optimizer/debugger/debugger.factor
+++ b/extra/optimizer/debugger/debugger.factor
@@ -47,24 +47,28 @@ MATCH-VARS: ?a ?b ?c ;
: pretty-shuffle ( in out -- word/f )
2array {
- { { { ?a } { } } drop }
- { { { ?a ?b } { } } 2drop }
- { { { ?a ?b ?c } { } } 3drop }
- { { { ?a } { ?a ?a } } dup }
- { { { ?a ?b } { ?a ?b ?a ?b } } 2dup }
- { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } 3dup }
- { { { ?a ?b } { ?a ?b ?a } } over }
- { { { ?b ?a } { ?a ?b } } swap }
- { { { ?a ?b ?c } { ?a ?b ?c ?a } } pick }
- { { { ?a ?b ?c } { ?c ?a ?b } } -rot }
- { { { ?a ?b ?c } { ?b ?c ?a } } rot }
- { { { ?a ?b } { ?b } } nip }
+ { { { ?a } { ?a } } [ ] }
+ { { { ?a ?b } { ?a ?b } } [ ] }
+ { { { ?a ?b ?c } { ?a ?b ?c } } [ ] }
+ { { { ?a } { } } [ drop ] }
+ { { { ?a ?b } { } } [ 2drop ] }
+ { { { ?a ?b ?c } { } } [ 3drop ] }
+ { { { ?a } { ?a ?a } } [ dup ] }
+ { { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] }
+ { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
+ { { { ?a ?b } { ?a ?b ?a } } [ over ] }
+ { { { ?b ?a } { ?a ?b } } [ swap ] }
+ { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
+ { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
+ { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
+ { { { ?a ?b } { ?b } } [ nip ] }
+ { { { ?a ?b ?c } { ?c } } [ 2nip ] }
{ _ f }
} match-choose ;
M: #shuffle node>quot
dup [ in-d>> ] [ out-d>> ] bi pretty-shuffle
- [ , ] [ >r drop t r> ] if*
+ [ % ] [ >r drop t r> ] if*
dup effect-str "#shuffle: " prepend comment, ;
: pushed-literals ( node -- seq )
From d278025a39fe01d6c6f4e3bb5991ca93d8a1cba0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 11 Jul 2008 20:33:08 -0500
Subject: [PATCH 04/14] Fix kernel tests
---
core/kernel/kernel-tests.factor | 4 ----
1 file changed, 4 deletions(-)
diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor
index c5bd0615a7..195e9becae 100755
--- a/core/kernel/kernel-tests.factor
+++ b/core/kernel/kernel-tests.factor
@@ -114,10 +114,6 @@ IN: kernel.tests
[ total-failure-1 ] must-fail
-: total-failure-2 [ ] (call) unimplemented ;
-
-[ total-failure-2 ] must-fail
-
! From combinators.lib
[ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] tri@ ] unit-test
[ 1 4 9 ] [ 1 2 3 [ sq ] tri@ ] unit-test
From 7e24f26b4d5baf5db0084ea2716adac3e288ca5d Mon Sep 17 00:00:00 2001
From: "U-VICTORIA\\Administrator" <Administrator@victoria.(none)>
Date: Fri, 11 Jul 2008 18:49:11 -0700
Subject: [PATCH 05/14] Add missing import to ui.windows
---
extra/ui/windows/windows.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor
index 231dd7f8a5..a210287439 100755
--- a/extra/ui/windows/windows.factor
+++ b/extra/ui/windows/windows.factor
@@ -8,7 +8,7 @@ sequences strings vectors words windows.kernel32 windows.gdi32
windows.user32 windows.opengl32 windows.messages windows.types
windows.nt windows threads libc combinators continuations
command-line shuffle opengl ui.render unicode.case ascii
-math.bitfields locals symbols accessors ;
+math.bitfields locals symbols accessors math.geometry.rect ;
IN: ui.windows
SINGLETON: windows-ui-backend
From f3d63e34acb79bb5558735cbc16f56f104352d92 Mon Sep 17 00:00:00 2001
From: "U-VICTORIA\\Administrator" <Administrator@victoria.(none)>
Date: Fri, 11 Jul 2008 18:50:26 -0700
Subject: [PATCH 06/14] Add LPGUID typedef to windows.ole32
---
extra/windows/ole32/ole32.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor
index 7daba37063..0e74dcfca3 100755
--- a/extra/windows/ole32/ole32.factor
+++ b/extra/windows/ole32/ole32.factor
@@ -10,6 +10,7 @@ TYPEDEF: void* LPUNKNOWN
TYPEDEF: wchar_t* LPOLESTR
TYPEDEF: wchar_t* LPCOLESTR
+TYPEDEF: REFGUID LPGUID
TYPEDEF: REFGUID REFIID
TYPEDEF: REFGUID REFCLSID
From 8d311fbf76e991c96542ff94da988b3f49cc382e Mon Sep 17 00:00:00 2001
From: "U-VICTORIA\\Administrator" <Administrator@victoria.(none)>
Date: Fri, 11 Jul 2008 18:51:25 -0700
Subject: [PATCH 07/14] Update bunny, spheres, demo-support to use delegation
---
extra/bunny/bunny.factor | 20 +++++++------------
extra/opengl/demo-support/demo-support.factor | 14 ++++++-------
extra/spheres/spheres.factor | 5 ++---
3 files changed, 16 insertions(+), 23 deletions(-)
diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor
index b4cefbc5bd..06959c91c2 100755
--- a/extra/bunny/bunny.factor
+++ b/extra/bunny/bunny.factor
@@ -7,28 +7,23 @@ opengl.demo-support multiline ui.gestures bunny.fixed-pipeline
bunny.cel-shaded bunny.outlined bunny.model accessors destructors ;
IN: bunny
-TUPLE: bunny-gadget model geom draw-seq draw-n ;
+TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ;
: <bunny-gadget> ( -- bunny-gadget )
- 0.0 0.0 0.375 <demo-gadget>
- maybe-download read-model {
- set-delegate
- (>>model)
- } bunny-gadget construct ;
+ 0.0 0.0 0.375 bunny-gadget new-demo-gadget
+ maybe-download read-model >>model-triangles ;
: bunny-gadget-draw ( gadget -- draw )
- { draw-n>> draw-seq>> }
- get-slots nth ;
+ [ draw-n>> ] [ draw-seq>> ] bi nth ;
: bunny-gadget-next-draw ( gadget -- )
- dup { draw-seq>> draw-n>> }
- get-slots
+ dup [ draw-seq>> ] [ draw-n>> ] bi
1+ swap length mod
>>draw-n relayout-1 ;
M: bunny-gadget graft* ( gadget -- )
GL_DEPTH_TEST glEnable
- dup model>> <bunny-geom> >>geom
+ dup model-triangles>> <bunny-geom> >>geom
dup
[ <bunny-fixed-pipeline> ]
[ <bunny-cel-shaded> ]
@@ -48,8 +43,7 @@ M: bunny-gadget draw-gadget* ( gadget -- )
dup demo-gadget-set-matrices
GL_MODELVIEW glMatrixMode
0.02 -0.105 0.0 glTranslatef
- { geom>> bunny-gadget-draw } get-slots
- draw-bunny
+ [ geom>> ] [ bunny-gadget-draw ] bi draw-bunny
] if ;
M: bunny-gadget pref-dim* ( gadget -- dim )
diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor
index 5dcbd526f2..2bf2abae95 100755
--- a/extra/opengl/demo-support/demo-support.factor
+++ b/extra/opengl/demo-support/demo-support.factor
@@ -9,10 +9,10 @@ IN: opengl.demo-support
SYMBOL: last-drag-loc
-TUPLE: demo-gadget yaw pitch distance ;
+TUPLE: demo-gadget < gadget yaw pitch distance ;
-: <demo-gadget> ( yaw pitch distance -- gadget )
- demo-gadget construct-gadget
+: new-demo-gadget ( yaw pitch distance class -- gadget )
+ new-gadget
swap >>distance
swap >>pitch
swap >>yaw ;
@@ -31,19 +31,19 @@ M: demo-gadget distance-step ( gadget -- dz )
: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
: yaw-demo-gadget ( yaw gadget -- )
- [ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ;
+ [ + ] with change-yaw relayout-1 ;
: pitch-demo-gadget ( pitch gadget -- )
- [ [ demo-gadget-pitch + ] keep set-demo-gadget-pitch ] keep relayout-1 ;
+ [ + ] with change-pitch relayout-1 ;
: zoom-demo-gadget ( distance gadget -- )
- [ [ demo-gadget-distance + ] keep set-demo-gadget-distance ] keep relayout-1 ;
+ [ + ] with change-distance relayout-1 ;
M: demo-gadget pref-dim* ( gadget -- dim )
drop { 640 480 } ;
: -+ ( x -- -x x )
- dup neg swap ;
+ [ neg ] keep ;
: demo-gadget-frustum ( gadget -- -x x -y y near far )
[ near-plane ] [ far-plane ] [ fov-ratio ] tri [
diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor
index dff7313eec..9607f6d201 100755
--- a/extra/spheres/spheres.factor
+++ b/extra/spheres/spheres.factor
@@ -99,14 +99,13 @@ main()
}
;
-TUPLE: spheres-gadget
+TUPLE: spheres-gadget < demo-gadget
plane-program solid-sphere-program texture-sphere-program
reflection-framebuffer reflection-depthbuffer
reflection-texture ;
: <spheres-gadget> ( -- gadget )
- 20.0 10.0 20.0 <demo-gadget>
- { set-delegate } spheres-gadget construct ;
+ 20.0 10.0 20.0 spheres-gadget new-demo-gadget ;
M: spheres-gadget near-plane ( gadget -- z )
drop 1.0 ;
From b19c3ee65e7655fbb9ce71692751bfe31a4e8ada Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 11 Jul 2008 19:34:42 -0700
Subject: [PATCH 08/14] use single-precision floats in bunny vertex buffers for
much better performance
---
extra/bunny/model/model.factor | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor
index fce73785b5..6723f94353 100755
--- a/extra/bunny/model/model.factor
+++ b/extra/bunny/model/model.factor
@@ -2,7 +2,7 @@ USING: alien alien.c-types arrays sequences math math.vectors
math.matrices math.parser io io.files kernel opengl opengl.gl
opengl.glu io.encodings.ascii opengl.capabilities shuffle
http.client vectors splitting system combinators
-float-arrays continuations destructors namespaces sequences.lib
+continuations destructors namespaces sequences.lib
accessors ;
IN: bunny.model
@@ -66,7 +66,7 @@ TUPLE: bunny-buffers array element-array nv ni ;
{
[
[ first concat ] [ second concat ] bi
- append >c-double-array
+ append >c-float-array
GL_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
]
[
@@ -86,10 +86,10 @@ M: bunny-dlist bunny-geom
M: bunny-buffers bunny-geom
dup { array>> element-array>> } get-slots [
{ GL_VERTEX_ARRAY GL_NORMAL_ARRAY } [
- GL_DOUBLE 0 0 buffer-offset glNormalPointer
+ GL_FLOAT 0 0 buffer-offset glNormalPointer
[
- nv>> "double" heap-size * buffer-offset
- 3 GL_DOUBLE 0 roll glVertexPointer
+ nv>> "float" heap-size * buffer-offset
+ 3 GL_FLOAT 0 roll glVertexPointer
] [
ni>>
GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
From 5b0fbf9abf092fac48da24353ba1632c6e703adc Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 11 Jul 2008 19:48:41 -0700
Subject: [PATCH 09/14] Whip the out-of-control USING: lines in bunny into
shape
---
extra/bunny/bunny.factor | 10 +++-------
extra/bunny/model/model.factor | 10 ++++------
2 files changed, 7 insertions(+), 13 deletions(-)
diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor
index 06959c91c2..ed89f2a809 100755
--- a/extra/bunny/bunny.factor
+++ b/extra/bunny/bunny.factor
@@ -1,10 +1,6 @@
-USING: alien alien.c-types arrays sequences math math.vectors
-math.matrices math.parser io io.files kernel opengl opengl.gl
-opengl.glu shuffle http.client vectors namespaces ui.gadgets
-ui.gadgets.canvas ui.render ui splitting combinators
-system combinators.lib float-arrays continuations
-opengl.demo-support multiline ui.gestures bunny.fixed-pipeline
-bunny.cel-shaded bunny.outlined bunny.model accessors destructors ;
+USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline
+bunny.model bunny.outlined destructors kernel math opengl.demo-support
+opengl.gl sequences ui ui.gadgets ui.gestures ui.render words ;
IN: bunny
TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ;
diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor
index 6723f94353..f64030ff70 100755
--- a/extra/bunny/model/model.factor
+++ b/extra/bunny/model/model.factor
@@ -1,9 +1,7 @@
-USING: alien alien.c-types arrays sequences math math.vectors
-math.matrices math.parser io io.files kernel opengl opengl.gl
-opengl.glu io.encodings.ascii opengl.capabilities shuffle
-http.client vectors splitting system combinators
-continuations destructors namespaces sequences.lib
-accessors ;
+USING: accessors alien.c-types arrays combinators destructors http.client
+io io.encodings.ascii io.files kernel math math.matrices math.parser
+math.vectors opengl opengl.capabilities opengl.gl sequences sequences.lib
+splitting vectors words ;
IN: bunny.model
: numbers ( str -- seq )
From 7608afbf4c445f1a6da613019fa9a67e86473c1a Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 11 Jul 2008 20:16:22 -0700
Subject: [PATCH 10/14] duh... bunny.outlined needs to update the framebuffer
size after it builds it!
---
extra/bunny/outlined/outlined.factor | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor
index f3ee4594c7..fcba98a0e9 100755
--- a/extra/bunny/outlined/outlined.factor
+++ b/extra/bunny/outlined/outlined.factor
@@ -181,10 +181,9 @@ TUPLE: bunny-outlined
] [ drop ] if ;
: remake-framebuffer-if-needed ( draw -- )
- dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi
- over =
- [ 2drop ] [
- [ dup dispose-framebuffer dup ] dip {
+ dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi =
+ [ drop ] [
+ [ dispose-framebuffer ] [ dup ] [ gadget>> dim>> ] tri {
[
GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
[ >>color-texture drop ] keep
@@ -196,7 +195,8 @@ TUPLE: bunny-outlined
[ >>depth-texture drop ] keep
]
} 2cleave
- (make-framebuffer) >>framebuffer drop
+ [ (make-framebuffer) >>framebuffer ] [ >>framebuffer-dim ] bi
+ drop
] if ;
: clear-framebuffer ( -- )
From 7ca3c2a878a8772c228f14888ef1259bf6e25bd4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 12 Jul 2008 01:08:30 -0500
Subject: [PATCH 11/14] Various minor compiler tweaks
---
core/alien/c-types/c-types-tests.factor | 2 +
core/alien/c-types/c-types.factor | 6 +-
core/classes/algebra/algebra-tests.factor | 6 ++
core/classes/singleton/singleton.factor | 6 +-
core/classes/tuple/tuple.factor | 2 +
core/growable/growable.factor | 7 ++
core/inference/class/class-tests.factor | 38 ++++++--
core/inference/class/class.factor | 19 +++-
core/inference/known-words/known-words.factor | 6 +-
core/io/encodings/encodings.factor | 21 +++--
core/io/encodings/utf8/utf8.factor | 14 +--
core/optimizer/inlining/inlining-tests.factor | 11 ---
core/optimizer/inlining/inlining.factor | 89 +++++++++++++------
core/optimizer/math/math.factor | 67 ++++++++++++--
core/optimizer/math/partial/partial.factor | 3 +
core/optimizer/optimizer-tests.factor | 9 ++
core/sequences/sequences.factor | 7 +-
core/slots/slots.factor | 6 +-
extra/benchmark/stack/stack.factor | 19 ++++
extra/float-arrays/float-arrays.factor | 17 ++++
extra/hints/hints.factor | 10 ++-
extra/io/buffers/buffers.factor | 2 +-
extra/io/ports/ports.factor | 18 ++--
extra/tools/deploy/shaker/shaker.factor | 1 +
24 files changed, 296 insertions(+), 90 deletions(-)
create mode 100644 extra/benchmark/stack/stack.factor
diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor
index 5f57068bab..276dd581c5 100755
--- a/core/alien/c-types/c-types-tests.factor
+++ b/core/alien/c-types/c-types-tests.factor
@@ -48,3 +48,5 @@ TYPEDEF: uchar* MyLPBYTE
[
0 B{ 1 2 3 4 } <displaced-alien> <void*>
] must-fail
+
+[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index 602b22881f..e576b87f52 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -348,7 +348,7 @@ M: long-long-type box-return ( type -- )
<c-type>
[ alien-unsigned-4 zero? not ] >>getter
- [ 1 0 ? set-alien-unsigned-4 ] >>setter
+ [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
"box_boolean" >>boxer
@@ -357,7 +357,7 @@ M: long-long-type box-return ( type -- )
<c-type>
[ alien-float ] >>getter
- [ >r >r >float r> r> set-alien-float ] >>setter
+ [ [ >float ] 2dip set-alien-float ] >>setter
4 >>size
4 >>align
"box_float" >>boxer
@@ -368,7 +368,7 @@ M: long-long-type box-return ( type -- )
<c-type>
[ alien-double ] >>getter
- [ >r >r >float r> r> set-alien-double ] >>setter
+ [ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
8 >>align
"box_double" >>boxer
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index 444cf50e58..665fc86ebb 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -306,3 +306,9 @@ INTERSECTION: empty-intersection ;
[ t ] [ object \ f class-not \ f class-or class<= ] unit-test
[ ] [ object flatten-builtin-class drop ] unit-test
+
+SINGLETON: sa
+SINGLETON: sb
+SINGLETON: sc
+
+[ sa ] [ sa { sa sb sc } min-class ] unit-test
diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor
index a72c9f1333..1d370c1859 100755
--- a/core/classes/singleton/singleton.factor
+++ b/core/classes/singleton/singleton.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.predicate kernel sequences words ;
+USING: classes classes.algebra classes.predicate kernel
+sequences words ;
IN: classes.singleton
PREDICATE: singleton-class < predicate-class
@@ -11,3 +12,6 @@ PREDICATE: singleton-class < predicate-class
\ word over [ eq? ] curry define-predicate-class ;
M: singleton-class instance? eq? ;
+
+M: singleton-class (classes-intersect?)
+ over singleton-class? [ eq? ] [ call-next-method ] if ;
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 6cf6a9897a..71c5f3efe6 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -336,6 +336,8 @@ M: tuple-class boa
[ tuple-layout ]
bi <tuple-boa> ;
+M: tuple-class initial-value* new ;
+
! Deprecated
M: object get-slots ( obj slots -- ... )
[ execute ] with each ;
diff --git a/core/growable/growable.factor b/core/growable/growable.factor
index 57919671c8..336f1da91a 100644
--- a/core/growable/growable.factor
+++ b/core/growable/growable.factor
@@ -59,4 +59,11 @@ M: growable lengthen ( n seq -- )
2dup (>>length)
] when 2drop ;
+M: growable shorten ( n seq -- )
+ growable-check
+ 2dup length < [
+ 2dup contract
+ 2dup (>>length)
+ ] when 2drop ;
+
INSTANCE: growable sequence
diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor
index 591baf1287..7be70f1ad4 100755
--- a/core/inference/class/class-tests.factor
+++ b/core/inference/class/class-tests.factor
@@ -5,8 +5,9 @@ sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
system layouts vectors optimizer.math.partial
-optimizer.inlining optimizer.backend math.order
-accessors hashtables classes assocs ;
+optimizer.inlining optimizer.backend math.order math.functions
+accessors hashtables classes assocs io.encodings.utf8
+io.encodings.ascii io.encodings ;
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
@@ -193,19 +194,15 @@ M: fixnum detect-fx ;
[ t ] [
- [ { string sbuf } declare push-all ] \ push-all inlined?
+ [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
] unit-test
[ t ] [
- [ { string sbuf } declare push-all ] \ + inlined?
+ [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
] unit-test
[ t ] [
- [ { string sbuf } declare push-all ] \ fixnum+ inlined?
-] unit-test
-
-[ t ] [
- [ { string sbuf } declare push-all ] \ >fixnum inlined?
+ [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
] unit-test
[ t ] [
@@ -600,6 +597,29 @@ TUPLE: declared-fixnum { x fixnum } ;
{ slot } inlined?
] unit-test
+[ t ] [
+ [
+ { array } declare length
+ 1 + dup 100 fixnum> [ 1 fixnum+ ] when
+ ] \ fixnum+ inlined?
+] unit-test
+
+[ t ] [
+ [ [ resize-array ] keep length ] \ length inlined?
+] unit-test
+
+[ t ] [
+ [ dup 0 > [ sqrt ] when ] \ sqrt inlined?
+] unit-test
+
+[ t ] [
+ [ { utf8 } declare decode-char ] \ decode-char inlined?
+] unit-test
+
+[ t ] [
+ [ { ascii } declare decode-char ] \ decode-char inlined?
+] unit-test
+
! Later
! [ t ] [
diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor
index 2f7058ba96..7cd0c1d540 100755
--- a/core/inference/class/class.factor
+++ b/core/inference/class/class.factor
@@ -129,8 +129,12 @@ GENERIC: infer-classes-before ( node -- )
GENERIC: infer-classes-around ( node -- )
+GENERIC: infer-classes-after ( node -- )
+
M: node infer-classes-before drop ;
+M: node infer-classes-after drop ;
+
M: node child-constraints
children>> length
dup zero? [ drop f ] [ f <repetition> ] if ;
@@ -203,11 +207,19 @@ M: pair constraint-satisfied?
[ ] [ param>> "default-output-classes" word-prop ] ?if
r> ;
-M: #call infer-classes-before
- [ compute-constraints ] keep
- [ output-classes ] [ out-d>> ] bi
+: intersect-values ( classes intervals values -- )
tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
+M: #call infer-classes-before
+ [ compute-constraints ]
+ [ [ output-classes ] [ out-d>> ] bi intersect-values ] bi ;
+
+: input-classes ( #call -- classes )
+ param>> "input-classes" word-prop ;
+
+M: #call infer-classes-after
+ [ input-classes ] [ in-d>> ] bi intersect-classes ;
+
M: #push infer-classes-before
out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
@@ -340,6 +352,7 @@ M: object infer-classes-around
{
[ infer-classes-before ]
[ annotate-node ]
+ [ infer-classes-after ]
[ infer-children ]
[ merge-children ]
} cleave ;
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 6f5277bc35..1c9138fe0b 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -153,8 +153,10 @@ M: object infer-call
] "infer" set-word-prop
: set-primitive-effect ( word effect -- )
- 2dup effect-out "default-output-classes" set-word-prop
- dupd [ make-call-node ] 2curry "infer" set-word-prop ;
+ [ in>> "input-classes" set-word-prop ]
+ [ out>> "default-output-classes" set-word-prop ]
+ [ dupd [ make-call-node ] 2curry "infer" set-word-prop ]
+ 2tri ;
! Stack effects for all primitives
\ fixnum< { fixnum fixnum } { object } <effect> set-primitive-effect
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index 942476616f..0181f80af4 100755
--- a/core/io/encodings/encodings.factor
+++ b/core/io/encodings/encodings.factor
@@ -99,14 +99,20 @@ M: decoder stream-read-partial stream-read ;
[ >r drop "" like r> ]
[ pick push ((read-until)) ] if ; inline
-: (read-until) ( seps stream -- string/f sep/f )
- SBUF" " clone -rot >decoder<
+: (read-until) ( quot -- string/f sep/f )
+ 100 <sbuf> swap ((read-until)) ; inline
+
+: decoder-read-until ( seps stream encoding -- string/f sep/f )
[ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry
- ((read-until)) ; inline
+ (read-until) ;
-M: decoder stream-read-until (read-until) ;
+M: decoder stream-read-until >decoder< decoder-read-until ;
-M: decoder stream-readln "\r\n" over (read-until) handle-readln ;
+: decoder-readln ( stream encoding -- string/f sep/f )
+ [ decode-char dup [ dup "\r\n" member? ] [ drop f t ] if ] 2curry
+ (read-until) ;
+
+M: decoder stream-readln dup >decoder< decoder-readln handle-readln ;
M: decoder dispose stream>> dispose ;
@@ -119,8 +125,11 @@ M: object <encoder> encoder boa ;
M: encoder stream-write1
>encoder< encode-char ;
+: decoder-write ( string stream encoding -- )
+ [ encode-char ] 2curry each ;
+
M: encoder stream-write
- >encoder< [ encode-char ] 2curry each ;
+ >encoder< decoder-write ;
M: encoder dispose encoder-stream dispose ;
diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor
index 09524802e0..ae8a455c71 100755
--- a/core/io/encodings/utf8/utf8.factor
+++ b/core/io/encodings/utf8/utf8.factor
@@ -11,21 +11,21 @@ SINGLETON: utf8
<PRIVATE
: starts-2? ( char -- ? )
- dup [ -6 shift BIN: 10 number= ] when ;
+ dup [ -6 shift BIN: 10 number= ] when ; inline
: append-nums ( stream byte -- stream char )
over stream-read1 dup starts-2?
[ swap 6 shift swap BIN: 111111 bitand bitor ]
- [ 2drop replacement-char ] if ;
+ [ 2drop replacement-char ] if ; inline
: double ( stream byte -- stream char )
- BIN: 11111 bitand append-nums ;
+ BIN: 11111 bitand append-nums ; inline
: triple ( stream byte -- stream char )
- BIN: 1111 bitand append-nums append-nums ;
+ BIN: 1111 bitand append-nums append-nums ; inline
: quad ( stream byte -- stream char )
- BIN: 111 bitand append-nums append-nums append-nums ;
+ BIN: 111 bitand append-nums append-nums append-nums ; inline
: begin-utf8 ( stream byte -- stream char )
{
@@ -34,10 +34,10 @@ SINGLETON: utf8
{ [ dup -4 shift BIN: 1110 number= ] [ triple ] }
{ [ dup -3 shift BIN: 11110 number= ] [ quad ] }
[ drop replacement-char ]
- } cond ;
+ } cond ; inline
: decode-utf8 ( stream -- char/f )
- dup stream-read1 dup [ begin-utf8 ] when nip ;
+ dup stream-read1 dup [ begin-utf8 ] when nip ; inline
M: utf8 decode-char
drop decode-utf8 ;
diff --git a/core/optimizer/inlining/inlining-tests.factor b/core/optimizer/inlining/inlining-tests.factor
index 7d98183160..64852e42ad 100644
--- a/core/optimizer/inlining/inlining-tests.factor
+++ b/core/optimizer/inlining/inlining-tests.factor
@@ -7,14 +7,3 @@ sequences growable sbufs vectors sequences.private accessors kernel ;
\ optimistic-inline? must-infer
\ find-identity must-infer
\ dispatching-class must-infer
-
-! Make sure we have sane heuristics
-[ t ] [ \ fixnum \ shift method should-inline? ] unit-test
-[ f ] [ \ array \ equal? method should-inline? ] unit-test
-[ f ] [ \ sequence \ hashcode* method should-inline? ] unit-test
-[ t ] [ \ array \ nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ growable \ nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ sbuf \ set-nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ growable \ set-nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ growable \ set-nth method should-inline? ] unit-test
-[ t ] [ \ vector \ (>>length) method should-inline? ] unit-test
diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor
index 618a2c746d..30acdb1b48 100755
--- a/core/optimizer/inlining/inlining.factor
+++ b/core/optimizer/inlining/inlining.factor
@@ -2,12 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
-math namespaces sequences vectors words quotations hashtables
-combinators classes classes.algebra generic.math
-optimizer.math.partial continuations optimizer.def-use
-optimizer.backend generic.standard optimizer.specializers
-optimizer.def-use optimizer.pattern-match generic.standard
-optimizer.control kernel.private definitions sets ;
+math math.order namespaces sequences vectors words quotations
+hashtables combinators effects classes classes.union
+classes.algebra generic.math optimizer.math.partial
+continuations optimizer.def-use optimizer.backend
+generic.standard optimizer.specializers optimizer.def-use
+optimizer.pattern-match generic.standard optimizer.control
+kernel.private definitions sets summary ;
IN: optimizer.inlining
: remember-inlining ( node history -- )
@@ -31,9 +32,9 @@ DEFER: (flat-length)
: word-flat-length ( word -- n )
{
! not inline
- { [ dup inline? not ] [ drop 0 ] }
+ { [ dup inline? not ] [ drop 1 ] }
! recursive and inline
- { [ dup recursive-calls get key? ] [ drop 4 ] }
+ { [ dup recursive-calls get key? ] [ drop 10 ] }
! inline
[ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
} cond ;
@@ -41,7 +42,7 @@ DEFER: (flat-length)
: (flat-length) ( seq -- n )
[
{
- { [ dup quotation? ] [ (flat-length) 1+ ] }
+ { [ dup quotation? ] [ (flat-length) 2 + ] }
{ [ dup array? ] [ (flat-length) ] }
{ [ dup word? ] [ word-flat-length ] }
[ drop 0 ]
@@ -51,7 +52,7 @@ DEFER: (flat-length)
: flat-length ( word -- n )
H{ } clone recursive-calls [
[ recursive-calls get conjoin ]
- [ def>> (flat-length) ]
+ [ def>> (flat-length) 5 /i ]
bi
] with-variable ;
@@ -102,7 +103,7 @@ DEFER: (flat-length)
[ f splice-quot ] [ 2drop t ] if ;
: inline-method ( #call -- node )
- dup node-param {
+ dup param>> {
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
{ [ dup math-partial? ] [ inline-math-partial ] }
@@ -155,15 +156,35 @@ DEFER: (flat-length)
(optimize-predicate) optimize-check ;
: flush-eval? ( #call -- ? )
- dup node-param "flushable" word-prop [
- node-out-d [ unused? ] all?
- ] [
- drop f
- ] if ;
+ dup node-param "flushable" word-prop
+ [ node-out-d [ unused? ] all? ] [ drop f ] if ;
+
+ERROR: flushed-eval-error word ;
+
+M: flushed-eval-error summary
+ drop "Flushed evaluation of word would have thrown an error" ;
+
+: flushed-eval-quot ( #call -- quot )
+ #! A quotation to replace flushed evaluations with. We can't
+ #! just remove the code altogether, because if the optimizer
+ #! knows the input types of a word, it assumes the inputs are
+ #! of this type after the word returns, since presumably
+ #! the word would have checked input types itself. However,
+ #! if the word gets flushed, then it won't do this checking;
+ #! so we have to do it here.
+ [
+ dup param>> "input-classes" word-prop [
+ make-specializer %
+ [ dup param>> literalize , \ flushed-eval-error , ] [ ] make ,
+ \ unless ,
+ ] when*
+ dup in-d>> length [ \ drop , ] times
+ out-d>> length [ f , ] times
+ ] [ ] make ;
: flush-eval ( #call -- node )
- dup node-param +inlined+ depends-on
- dup node-out-d length f <repetition> inline-literals ;
+ dup param>> +inlined+ depends-on
+ dup flushed-eval-quot f splice-quot ;
: partial-eval? ( #call -- ? )
dup node-param "foldable" word-prop [
@@ -195,13 +216,28 @@ DEFER: (flat-length)
[ drop +inlined+ depends-on ] [ swap 1array ] 2bi
splice-quot ;
+: classes-known? ( #call -- ? )
+ node-input-classes [
+ [ class-types length 1 = ]
+ [ union-class? not ]
+ bi and
+ ] contains? ;
+
+: inlining-rank ( #call -- n )
+ {
+ [ param>> flat-length 24 swap [-] 4 /i ]
+ [ param>> "default" word-prop -4 0 ? ]
+ [ param>> "specializer" word-prop 1 0 ? ]
+ [ param>> method-body? 1 0 ? ]
+ [ classes-known? 2 0 ? ]
+ } cleave + + + + ;
+
+: should-inline? ( #call -- ? )
+ inlining-rank 5 >= ;
+
: optimistic-inline? ( #call -- ? )
- dup node-param "specializer" word-prop dup [
- >r node-input-classes r> specialized-length tail*
- [ class-types length 1 = ] all?
- ] [
- 2drop f
- ] if ;
+ dup param>> "specializer" word-prop
+ [ should-inline? ] [ drop f ] if ;
: already-inlined? ( #call -- ? )
[ param>> ] [ history>> ] bi memq? ;
@@ -211,11 +247,8 @@ DEFER: (flat-length)
dup param>> dup def>> splice-word-def
] if ;
-: should-inline? ( word -- ? )
- flat-length 11 <= ;
-
: method-body-inline? ( #call -- ? )
- param>> dup [ method-body? ] [ "default" word-prop not ] bi and
+ dup param>> method-body?
[ should-inline? ] [ drop f ] if ;
M: #call optimize-node*
diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor
index 27ef4042e2..799f4d80cf 100755
--- a/core/optimizer/math/math.factor
+++ b/core/optimizer/math/math.factor
@@ -1,14 +1,15 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: effects alien alien.accessors arrays generic hashtables
+kernel assocs math math.libm math.private kernel.private
+sequences words parser inference.class inference.dataflow
+vectors strings sbufs io namespaces assocs quotations
+math.intervals sequences.private combinators splitting layouts
+math.parser classes classes.algebra generic.math
+optimizer.pattern-match optimizer.backend optimizer.def-use
+optimizer.inlining optimizer.math.partial generic.standard
+system accessors ;
IN: optimizer.math
-USING: alien alien.accessors arrays generic hashtables kernel
-assocs math math.private kernel.private sequences words parser
-inference.class inference.dataflow vectors strings sbufs io
-namespaces assocs quotations math.intervals sequences.private
-combinators splitting layouts math.parser classes
-classes.algebra generic.math optimizer.pattern-match
-optimizer.backend optimizer.def-use optimizer.inlining
-optimizer.math.partial generic.standard system accessors ;
: define-math-identities ( word identities -- )
>r all-derived-ops r> define-identities ;
@@ -169,6 +170,22 @@ optimizer.math.partial generic.standard system accessors ;
] 2curry each-derived-op
] each
+: math-output-class/interval-2-fast ( node word -- classes intervals )
+ math-output-interval-2 fixnum [ 1array ] bi@ swap ; inline
+
+[
+ { + interval+ }
+ { - interval- }
+ { * interval* }
+ { shift interval-shift-safe }
+] [
+ first2 [
+ [
+ math-output-class/interval-2-fast
+ ] curry "output-classes" set-word-prop
+ ] curry each-fast-derived-op
+] each
+
: real-value? ( value -- n ? )
dup value? [ value-literal dup real? ] [ drop f f ] if ;
@@ -420,3 +437,37 @@ most-negative-fixnum most-positive-fixnum [a,b]
[ fixnumify-bitand ]
}
} define-optimizers
+
+{ + - * / }
+[ { number number } "input-classes" set-word-prop ] each
+
+{ /f < > <= >= }
+[ { real real } "input-classes" set-word-prop ] each
+
+{ /i bitand bitor bitxor bitnot shift }
+[ { integer integer } "input-classes" set-word-prop ] each
+
+{
+ 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
diff --git a/core/optimizer/math/partial/partial.factor b/core/optimizer/math/partial/partial.factor
index 4f9bfaef12..ad9feeed4a 100644
--- a/core/optimizer/math/partial/partial.factor
+++ b/core/optimizer/math/partial/partial.factor
@@ -170,3 +170,6 @@ SYMBOL: fast-math-ops
: each-derived-op ( word quot -- )
>r derived-ops r> each ; inline
+
+: each-fast-derived-op ( word quot -- )
+ >r fast-derived-ops r> each ; inline
diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor
index 655b54ea96..0a3439c65c 100755
--- a/core/optimizer/optimizer-tests.factor
+++ b/core/optimizer/optimizer-tests.factor
@@ -375,3 +375,12 @@ PREDICATE: list < improper-list
[ 2 3 ] [ 2 interval-inference-bug ] unit-test
[ 1 4 ] [ 1 interval-inference-bug ] unit-test
[ 0 5 ] [ 0 interval-inference-bug ] unit-test
+
+: aggressive-flush-regression ( a -- b )
+ f over >r <array> drop r> 1 + ;
+
+[ 1.0 aggressive-flush-regression drop ] must-fail
+
+[ 1 [ "hi" + drop ] compile-call ] must-fail
+
+[ "hi" f [ <array> drop ] compile-call ] must-fail
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index bc92055338..c433ce4426 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -21,9 +21,12 @@ GENERIC: clone-like ( seq exemplar -- newseq ) flushable
M: sequence like drop ;
GENERIC: lengthen ( n seq -- )
+GENERIC: shorten ( n seq -- )
M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
+M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
+
: empty? ( seq -- ? ) length zero? ; inline
: delete-all ( seq -- ) 0 swap set-length ;
@@ -530,7 +533,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: peek ( seq -- elt ) [ length 1- ] [ nth ] bi ;
-: pop* ( seq -- ) [ length 1- ] [ set-length ] bi ;
+: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ;
: move-backward ( shift from to seq -- )
2over number= [
@@ -575,7 +578,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
copy ;
: pop ( seq -- elt )
- [ length 1- ] [ [ nth ] [ set-length ] 2bi ] bi ;
+ [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
: all-equal? ( seq -- ? ) [ = ] monotonic? ;
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 1453393a27..a5b2e4b3d8 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -125,6 +125,10 @@ ERROR: bad-slot-value value class ;
ERROR: no-initial-value class ;
+GENERIC: initial-value* ( class -- object )
+
+M: class initial-value* no-initial-value ;
+
: initial-value ( class -- object )
{
{ [ \ f bootstrap-word over class<= ] [ f ] }
@@ -134,7 +138,7 @@ ERROR: no-initial-value class ;
{ [ array bootstrap-word over class<= ] [ { } ] }
{ [ byte-array bootstrap-word over class<= ] [ B{ } ] }
{ [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
- [ no-initial-value ]
+ [ dup initial-value* ]
} cond nip ;
GENERIC: make-slot ( desc -- slot-spec )
diff --git a/extra/benchmark/stack/stack.factor b/extra/benchmark/stack/stack.factor
new file mode 100644
index 0000000000..d4dc18e80f
--- /dev/null
+++ b/extra/benchmark/stack/stack.factor
@@ -0,0 +1,19 @@
+USING: kernel sequences math math.functions vectors ;
+IN: benchmark.stack
+
+: stack-loop ( vec -- )
+ 1000 [
+ 10000 [
+ dup pop dup ! dup 10 > [ sqrt dup 1 + ] [ dup 2 * ] if
+ pick push
+ over push
+ ] times
+ 10000 [ dup pop* ] times
+ ] times
+ drop ;
+
+: stack-benchmark ( -- )
+ V{ 123456 } clone stack-loop
+ 20000 <vector> 123456 over set-first stack-loop ;
+
+MAIN: stack-benchmark
diff --git a/extra/float-arrays/float-arrays.factor b/extra/float-arrays/float-arrays.factor
index 025a580633..668bb7de41 100755
--- a/extra/float-arrays/float-arrays.factor
+++ b/extra/float-arrays/float-arrays.factor
@@ -72,3 +72,20 @@ INSTANCE: float-array sequence
M: float-array pprint-delims drop \ F{ \ } ;
M: float-array >pprint-sequence ;
+
+USING: hints math.vectors arrays ;
+
+HINTS: vneg { float-array } { array } ;
+HINTS: v*n { float-array object } { array object } ;
+HINTS: v/n { float-array object } { array object } ;
+HINTS: n/v { object float-array } { object array } ;
+HINTS: v+ { float-array float-array } { array array } ;
+HINTS: v- { float-array float-array } { array array } ;
+HINTS: v* { float-array float-array } { array array } ;
+HINTS: v/ { float-array float-array } { array array } ;
+HINTS: vmax { float-array float-array } { array array } ;
+HINTS: vmin { float-array float-array } { array array } ;
+HINTS: v. { float-array float-array } { array array } ;
+HINTS: norm-sq { float-array } { array } ;
+HINTS: norm { float-array } { array } ;
+HINTS: normalize { float-array } { array } ;
diff --git a/extra/hints/hints.factor b/extra/hints/hints.factor
index 266e635867..82941a69de 100644
--- a/extra/hints/hints.factor
+++ b/extra/hints/hints.factor
@@ -1,6 +1,10 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser words definitions kernel ;
IN: hints
-USING: parser words ;
-: HINTS:
- scan-word parse-definition "specializer" set-word-prop ;
+: HINTS:
+ scan-word
+ [ +inlined+ changed-definition ]
+ [ parse-definition "specializer" set-word-prop ] bi ;
parsing
diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor
index f08082c4ee..e6a0070ee0 100755
--- a/extra/io/buffers/buffers.factor
+++ b/extra/io/buffers/buffers.factor
@@ -25,7 +25,7 @@ M: buffer dispose* ptr>> free ;
[ size>> ] [ fill>> ] bi - ; inline
: buffer-empty? ( buffer -- ? )
- fill>> zero? ;
+ fill>> zero? ; inline
: buffer-consume ( n buffer -- )
[ + ] change-pos
diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor
index 77e984e6e5..26b06dba8b 100755
--- a/extra/io/ports/ports.factor
+++ b/extra/io/ports/ports.factor
@@ -19,7 +19,7 @@ M: port set-timeout (>>timeout) ;
: <port> ( handle class -- port )
new swap >>handle ; inline
-TUPLE: buffered-port < port buffer ;
+TUPLE: buffered-port < port { buffer buffer } ;
: <buffered-port> ( handle class -- port )
<port>
@@ -35,7 +35,7 @@ HOOK: (wait-to-read) io-backend ( port -- )
: wait-to-read ( port -- eof? )
dup buffer>> buffer-empty? [
dup (wait-to-read) buffer>> buffer-empty?
- ] [ drop f ] if ;
+ ] [ drop f ] if ; inline
M: input-port stream-read1
dup check-disposed
@@ -140,9 +140,7 @@ M: output-port dispose*
] with-destructors ;
M: buffered-port dispose*
- [ call-next-method ]
- [ [ [ dispose ] when* f ] change-buffer drop ]
- bi ;
+ [ call-next-method ] [ buffer>> dispose ] bi ;
M: port cancel-operation handle>> cancel-operation ;
@@ -152,3 +150,13 @@ M: port dispose*
[ handle>> shutdown ]
bi
] with-destructors ;
+
+! Fast-path optimization
+USING: hints strings io.encodings.utf8 io.encodings.ascii
+io.encodings.private ;
+
+HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii } ;
+
+HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;
+
+HINTS: decoder-write { string output-port utf8 } { string output-port ascii } ;
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index 2dd334d024..0e20384839 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -101,6 +101,7 @@ IN: tools.deploy.shaker
"if-intrinsics"
"infer"
"inferred-effect"
+ "input-classes"
"interval"
"intrinsics"
"loc"
From 1253aed5cd4ebc6d29d651fc79dab8037eba6c1f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 12 Jul 2008 01:24:10 -0500
Subject: [PATCH 12/14] Doc update
---
core/slots/slots-docs.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor
index 39a501c7f8..acca168a4c 100755
--- a/core/slots/slots-docs.factor
+++ b/core/slots/slots-docs.factor
@@ -77,6 +77,7 @@ $nl
"All other classes are handled with one of two cases:"
{ $list
{ "If the class is a union or mixin class which " { $emphasis "contains" } " one of the above known classes, then the initial value of the class is that of the known class, with preference given to classes earlier in the list. For example, if the slot is declared " { $link object } " (this is the default), the initial value is " { $link f } ". Similarly for " { $link sequence } " and " { $link assoc } "." }
+ { "If the class is a tuple class, the initial value of the slot is a new, shared instance of the class created with " { $link new } "." }
{ "Otherwise, a " { $link no-initial-value } " error is thrown. In this case, an initial value must be specified explicitly using " { $link initial: } "." }
}
"A word can be used to check if a class has an initial value or not:"
From 41adbaf6bec27b5339a34fcddb35ec7c7ed86023 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 12 Jul 2008 01:29:12 -0500
Subject: [PATCH 13/14] Fix display regression
---
extra/ui/gadgets/borders/borders.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor
index 2c232392ce..7d6a24fed1 100644
--- a/extra/ui/gadgets/borders/borders.factor
+++ b/extra/ui/gadgets/borders/borders.factor
@@ -33,7 +33,8 @@ M: border pref-dim*
[ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
: border-loc ( border dim -- loc )
- [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip v- v* v+ ;
+ [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip
+ v- v* v+ [ >fixnum ] map ;
: border-child-rect ( border -- rect )
dup border-dim [ border-loc ] keep <rect> ;
From 3e082f21e37c0ff5f83a1d05e99110fa61d32e32 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 12 Jul 2008 01:29:25 -0500
Subject: [PATCH 14/14] Update minor demos for inheritance
---
extra/gesture-logger/gesture-logger.factor | 4 ++--
extra/nehe/2/2.factor | 4 ++--
extra/nehe/3/3.factor | 4 ++--
extra/nehe/4/4.factor | 4 ++--
extra/nehe/5/5.factor | 4 ++--
5 files changed, 10 insertions(+), 10 deletions(-)
diff --git a/extra/gesture-logger/gesture-logger.factor b/extra/gesture-logger/gesture-logger.factor
index ba0ff5bedd..d79593c337 100644
--- a/extra/gesture-logger/gesture-logger.factor
+++ b/extra/gesture-logger/gesture-logger.factor
@@ -5,10 +5,10 @@ ui.gadgets.scrollers ui.gadgets.theme ui.gestures colors
accessors ;
IN: gesture-logger
-TUPLE: gesture-logger stream ;
+TUPLE: gesture-logger < gadget stream ;
: <gesture-logger> ( stream -- gadget )
- \ gesture-logger construct-gadget
+ \ gesture-logger new-gadget
swap >>stream
{ 100 100 } >>dim
black solid-interior ;
diff --git a/extra/nehe/2/2.factor b/extra/nehe/2/2.factor
index 1084a3303e..d9560c92f6 100644
--- a/extra/nehe/2/2.factor
+++ b/extra/nehe/2/2.factor
@@ -2,13 +2,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui
ui.gadgets ui.render ;
IN: nehe.2
-TUPLE: nehe2-gadget ;
+TUPLE: nehe2-gadget < gadget ;
: width 256 ;
: height 256 ;
: <nehe2-gadget> ( -- gadget )
- nehe2-gadget construct-gadget ;
+ nehe2-gadget new-gadget ;
M: nehe2-gadget pref-dim* ( gadget -- dim )
drop width height 2array ;
diff --git a/extra/nehe/3/3.factor b/extra/nehe/3/3.factor
index fff58380d6..8a2149e370 100644
--- a/extra/nehe/3/3.factor
+++ b/extra/nehe/3/3.factor
@@ -2,13 +2,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui
ui.gadgets ui.render ;
IN: nehe.3
-TUPLE: nehe3-gadget ;
+TUPLE: nehe3-gadget < gadget ;
: width 256 ;
: height 256 ;
: <nehe3-gadget> ( -- gadget )
- nehe3-gadget construct-gadget ;
+ nehe3-gadget new-gadget ;
M: nehe3-gadget pref-dim* ( gadget -- dim )
drop width height 2array ;
diff --git a/extra/nehe/4/4.factor b/extra/nehe/4/4.factor
index b87b4a2308..fc2727159b 100644
--- a/extra/nehe/4/4.factor
+++ b/extra/nehe/4/4.factor
@@ -2,14 +2,14 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui
ui.gadgets ui.render threads ;
IN: nehe.4
-TUPLE: nehe4-gadget rtri rquad thread quit? ;
+TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
: width 256 ;
: height 256 ;
: redraw-interval 10 ;
: <nehe4-gadget> ( -- gadget )
- nehe4-gadget construct-gadget
+ nehe4-gadget new-gadget
0.0 over set-nehe4-gadget-rtri
0.0 over set-nehe4-gadget-rquad ;
diff --git a/extra/nehe/5/5.factor b/extra/nehe/5/5.factor
index 31a7d059ae..f399a116ed 100755
--- a/extra/nehe/5/5.factor
+++ b/extra/nehe/5/5.factor
@@ -2,13 +2,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui
ui.gadgets ui.render threads ;
IN: nehe.5
-TUPLE: nehe5-gadget rtri rquad thread quit? ;
+TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
: width 256 ;
: height 256 ;
: redraw-interval 10 ;
: <nehe5-gadget> ( -- gadget )
- nehe5-gadget construct-gadget
+ nehe5-gadget new-gadget
0.0 over set-nehe5-gadget-rtri
0.0 over set-nehe5-gadget-rquad ;