From 2e119a0ae72d83f62f9742b174735d6944b6d29b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.local>
Date: Mon, 31 Aug 2009 05:42:28 -0500
Subject: [PATCH 1/6] struct-arrays: hack it up so that if the class name is a
literal parameter for the constructor, then the array works in deployed apps
even if not every call site of nth or set-nth is inlined on the array. Fixes
tools.deploy.test.5 regression after kqueue was converted to use STRUCT:.
Because of Dan's call(-inlining, no perf regression on struct-arrays
benchmark!
---
basis/struct-arrays/struct-arrays.factor | 44 ++++++++++++++++--------
1 file changed, 29 insertions(+), 15 deletions(-)
diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor
index a3dcd98f0e..73eb356a60 100755
--- a/basis/struct-arrays/struct-arrays.factor
+++ b/basis/struct-arrays/struct-arrays.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.structs byte-arrays
-classes.struct kernel libc math parser sequences sequences.private ;
+classes.struct kernel libc math parser sequences
+sequences.private words fry memoize compiler.units ;
IN: struct-arrays
: c-type-struct-class ( c-type -- class )
@@ -11,7 +12,8 @@ TUPLE: struct-array
{ underlying c-ptr read-only }
{ length array-capacity read-only }
{ element-size array-capacity read-only }
-{ class read-only } ;
+{ class read-only }
+{ ctor read-only } ;
M: struct-array length length>> ; inline
M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
@@ -20,34 +22,46 @@ M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
[ element-size>> * >fixnum ] [ underlying>> ] bi <displaced-alien> ; inline
M: struct-array nth-unsafe
- [ (nth-ptr) ] [ class>> dup struct-class? ] bi [ memory>struct ] [ drop ] if ; inline
+ [ (nth-ptr) ] [ ctor>> ] bi execute( alien -- object ) ; inline
M: struct-array set-nth-unsafe
[ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
+! Foldable memo word. This is an optimization; by precompiling a
+! constructor for array elements, we avoid memory>struct's slow path.
+MEMO: struct-element-constructor ( c-type -- word )
+ [
+ "struct-array-ctor" f <word>
+ [
+ swap dup struct-class?
+ [ '[ _ memory>struct ] [ ] like ] [ drop [ ] ] if
+ (( alien -- object )) define-inline
+ ] keep
+ ] with-compilation-unit ; foldable
+
+: <direct-struct-array> ( alien length c-type -- struct-array )
+ [ heap-size ] [ c-type-struct-class ] [ struct-element-constructor ]
+ tri struct-array boa ; inline
+
M: struct-array new-sequence
- [ element-size>> [ * (byte-array) ] 2keep ]
- [ class>> ] bi struct-array boa ; inline
+ [ element-size>> * (byte-array) ] [ length>> ] [ class>> ] tri
+ <direct-struct-array> ; inline
M: struct-array resize ( n seq -- newseq )
- [ [ element-size>> * ] [ underlying>> ] bi resize ]
- [ [ element-size>> ] [ class>> ] bi ] 2bi
- struct-array boa ;
+ [ [ element-size>> * ] [ underlying>> ] bi resize ] [ class>> ] 2bi
+ <direct-struct-array> ; inline
: <struct-array> ( length c-type -- struct-array )
- [ heap-size [ * <byte-array> ] 2keep ]
- [ c-type-struct-class ] bi struct-array boa ; inline
+ [ heap-size * <byte-array> ] 2keep <direct-struct-array> ; inline
ERROR: bad-byte-array-length byte-array ;
: byte-array>struct-array ( byte-array c-type -- struct-array )
- [ heap-size [
+ [
+ heap-size
[ dup length ] dip /mod 0 =
[ drop bad-byte-array-length ] unless
- ] keep ] [ c-type-struct-class ] bi struct-array boa ; inline
-
-: <direct-struct-array> ( alien length c-type -- struct-array )
- [ heap-size ] [ c-type-struct-class ] bi struct-array boa ; inline
+ ] keep <direct-struct-array> ; inline
: malloc-struct-array ( length c-type -- struct-array )
[ heap-size calloc ] 2keep <direct-struct-array> ; inline
From ab45402d04b0591e127590007edb20dcaaf1cf20 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.local>
Date: Mon, 31 Aug 2009 05:46:57 -0500
Subject: [PATCH 2/6] Minor doc improvements
---
core/combinators/combinators-docs.factor | 20 +++++++++++++++++---
core/syntax/syntax-docs.factor | 10 +++++++++-
2 files changed, 26 insertions(+), 4 deletions(-)
diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor
index 7395014bed..4a7fcea0e6 100755
--- a/core/combinators/combinators-docs.factor
+++ b/core/combinators/combinators-docs.factor
@@ -275,7 +275,7 @@ $nl
"The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:"
{ $subsection call }
{ $subsection execute }
-"The second set of combinators takes an effect declaration. The stack effect of the quotation or word is checked at runtime:"
+"The second set of combinators takes an effect declaration. Note that the opening parenthesis is actually part of the word name; these are parsing words, and they read a stack effect until the corresponding closing parenthesis. The stack effect of the quotation or word is then checked at runtime:"
{ $subsection POSTPONE: call( }
{ $subsection POSTPONE: execute( }
"The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:"
@@ -303,11 +303,25 @@ ABOUT: "combinators"
HELP: call-effect
{ $values { "quot" quotation } { "effect" effect } }
-{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
+{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." }
+{ $examples
+ "The following two lines are equivalent:"
+ { $code
+ "call( a b -- c )"
+ "(( a b -- c )) call-effect"
+ }
+} ;
HELP: execute-effect
{ $values { "word" word } { "effect" effect } }
-{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
+{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." }
+{ $examples
+ "The following two lines are equivalent:"
+ { $code
+ "execute( a b -- c )"
+ "(( a b -- c )) execute-effect"
+ }
+} ;
HELP: execute-effect-unsafe
{ $values { "word" word } { "effect" effect } }
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index cc4b080491..50c7c047c7 100644
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -834,6 +834,14 @@ HELP: call(
HELP: execute(
{ $syntax "execute( stack -- effect )" }
-{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ;
+{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." }
+{ $examples
+ { $code
+ "IN: scratchpad"
+ ""
+ ": eat ( -- ) ; : sleep ( -- ) ; : hack ( -- ) ;"
+ "{ eat sleep hack } [ execute( -- ) ] each"
+ }
+} ;
{ POSTPONE: call( POSTPONE: execute( } related-words
From 740856eeca04cb1839426c87263057e9cd36cbfc Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 31 Aug 2009 15:22:26 -0500
Subject: [PATCH 3/6] fix windows usings
---
basis/windows/com/wrapper/wrapper.factor | 3 ++-
basis/windows/ole32/ole32-tests.factor | 3 ++-
2 files changed, 4 insertions(+), 2 deletions(-)
diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor
index 3d78ccc849..2af416fb7e 100755
--- a/basis/windows/com/wrapper/wrapper.factor
+++ b/basis/windows/com/wrapper/wrapper.factor
@@ -3,7 +3,8 @@ init windows.com.syntax.private windows.com continuations kernel
namespaces windows.ole32 libc vocabs assocs accessors arrays
sequences quotations combinators math words compiler.units
destructors fry math.parser generalizations sets
-specialized-arrays.alien specialized-arrays.direct.alien ;
+specialized-arrays.alien specialized-arrays.direct.alien
+windows.kernel32 ;
IN: windows.com.wrapper
TUPLE: com-wrapper < disposable callbacks vtbls ;
diff --git a/basis/windows/ole32/ole32-tests.factor b/basis/windows/ole32/ole32-tests.factor
index aa02211ef3..c8358f5aa6 100644
--- a/basis/windows/ole32/ole32-tests.factor
+++ b/basis/windows/ole32/ole32-tests.factor
@@ -1,5 +1,6 @@
USING: kernel tools.test windows.ole32 alien.c-types
-classes.struct specialized-arrays.uchar windows.kernel32 ;
+classes.struct specialized-arrays.uchar windows.kernel32
+windows.com.syntax ;
IN: windows.ole32.tests
[ t ] [
From 23f34febbbbe57d5508416eacd5fefefe0f847ae Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.local>
Date: Mon, 31 Aug 2009 16:34:58 -0500
Subject: [PATCH 4/6] Fix image size regression with struct array tree shaking
---
basis/struct-arrays/struct-arrays.factor | 11 +++++++----
basis/tools/deploy/shaker/shaker.factor | 12 +++++++++---
.../tools/deploy/shaker/strip-struct-arrays.factor | 13 +++++++++++++
3 files changed, 29 insertions(+), 7 deletions(-)
create mode 100644 basis/tools/deploy/shaker/strip-struct-arrays.factor
diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor
index 73eb356a60..38dab33f0e 100755
--- a/basis/struct-arrays/struct-arrays.factor
+++ b/basis/struct-arrays/struct-arrays.factor
@@ -27,9 +27,7 @@ M: struct-array nth-unsafe
M: struct-array set-nth-unsafe
[ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
-! Foldable memo word. This is an optimization; by precompiling a
-! constructor for array elements, we avoid memory>struct's slow path.
-MEMO: struct-element-constructor ( c-type -- word )
+: (struct-element-constructor) ( c-type -- word )
[
"struct-array-ctor" f <word>
[
@@ -37,7 +35,12 @@ MEMO: struct-element-constructor ( c-type -- word )
[ '[ _ memory>struct ] [ ] like ] [ drop [ ] ] if
(( alien -- object )) define-inline
] keep
- ] with-compilation-unit ; foldable
+ ] with-compilation-unit ;
+
+! Foldable memo word. This is an optimization; by precompiling a
+! constructor for array elements, we avoid memory>struct's slow path.
+MEMO: struct-element-constructor ( c-type -- word )
+ (struct-element-constructor) ; foldable
: <direct-struct-array> ( alien length c-type -- struct-array )
[ heap-size ] [ c-type-struct-class ] [ struct-element-constructor ]
diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index 6a133d9c87..2244eb9249 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -68,9 +68,14 @@ IN: tools.deploy.shaker
] when ;
: strip-destructors ( -- )
- "libc" vocab [
- "Stripping destructor debug code" show
- "vocab:tools/deploy/shaker/strip-destructors.factor"
+ "Stripping destructor debug code" show
+ "vocab:tools/deploy/shaker/strip-destructors.factor"
+ run-file ;
+
+: strip-struct-arrays ( -- )
+ "struct-arrays" vocab [
+ "Stripping dynamic struct array code" show
+ "vocab:tools/deploy/shaker/strip-struct-arrays.factor"
run-file
] when ;
@@ -493,6 +498,7 @@ SYMBOL: deploy-vocab
: strip ( -- )
init-stripper
strip-libc
+ strip-struct-arrays
strip-destructors
strip-call
strip-cocoa
diff --git a/basis/tools/deploy/shaker/strip-struct-arrays.factor b/basis/tools/deploy/shaker/strip-struct-arrays.factor
new file mode 100644
index 0000000000..55b6630082
--- /dev/null
+++ b/basis/tools/deploy/shaker/strip-struct-arrays.factor
@@ -0,0 +1,13 @@
+USING: kernel stack-checker.transforms ;
+IN: struct-arrays
+
+: struct-element-constructor ( c-type -- word )
+ "Struct array usages must be compiled" throw ;
+
+<<
+
+\ struct-element-constructor [
+ (struct-element-constructor) [ ] curry
+] 1 define-transform
+
+>>
\ No newline at end of file
From 94c89e55e6e8cbf27898f62a18b7edcae29aed7b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.local>
Date: Mon, 31 Aug 2009 16:48:10 -0500
Subject: [PATCH 5/6] tools.deploy.shaker: strip out call( and execute( runtime
checking in a way that still allows the inlining optimization to work
---
basis/tools/deploy/shaker/strip-call.factor | 14 +++++++++-----
1 file changed, 9 insertions(+), 5 deletions(-)
diff --git a/basis/tools/deploy/shaker/strip-call.factor b/basis/tools/deploy/shaker/strip-call.factor
index d0593b6c15..0ecc22e4c0 100644
--- a/basis/tools/deploy/shaker/strip-call.factor
+++ b/basis/tools/deploy/shaker/strip-call.factor
@@ -1,10 +1,14 @@
! Copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-IN: tools.deploy.shaker.call
-
+USING: combinators.private kernel ;
IN: combinators
-USE: combinators.private
-: call-effect ( word effect -- ) call-effect-unsafe ; inline
+: call-effect ( word effect -- ) call-effect-unsafe ;
-: execute-effect ( word effect -- ) execute-effect-unsafe ; inline
\ No newline at end of file
+: execute-effect ( word effect -- ) execute-effect-unsafe ;
+
+IN: compiler.tree.propagation.call-effect
+
+: call-effect-unsafe? ( quot effect -- ? ) 2drop t ; inline
+
+: execute-effect-unsafe? ( word effect -- ? ) 2drop t ; inline
\ No newline at end of file
From f6da4856b44903f0eec791c2305deb581536fc0b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.local>
Date: Mon, 31 Aug 2009 17:07:24 -0500
Subject: [PATCH 6/6] benchmark.yuv-to-rgb: fix hints
---
extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor
index 561b6f0c0a..8041bef07f 100644
--- a/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor
+++ b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor
@@ -86,7 +86,7 @@ STRUCT: yuv_buffer
[ yuv>rgb-row ] with with each
drop ;
-HINTS: yuv>rgb byte-array byte-array ;
+HINTS: yuv>rgb byte-array yuv_buffer ;
: yuv>rgb-benchmark ( -- )
[ fake-data yuv>rgb ] with-destructors ;