Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
a89aea1a78
|
|
@ -74,6 +74,12 @@ nl
|
|||
malloc free memcpy
|
||||
} compile
|
||||
|
||||
[ compiled-usages recompile ] recompile-hook set-global
|
||||
: enable-compiler ( -- )
|
||||
[ compiled-usages recompile ] recompile-hook set-global ;
|
||||
|
||||
: disable-compiler ( -- )
|
||||
[ [ f ] { } map>assoc modify-code-heap ] recompile-hook set-global ;
|
||||
|
||||
enable-compiler
|
||||
|
||||
" done" print flush
|
||||
|
|
|
|||
|
|
@ -7,11 +7,7 @@ ARTICLE: "combinators-quot" "Quotation construction utilities"
|
|||
"Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
|
||||
{ $subsection cond>quot }
|
||||
{ $subsection case>quot }
|
||||
{ $subsection alist>quot }
|
||||
"A powerful tool used to optimize code in several places is open-coded hashtable dispatch:"
|
||||
{ $subsection hash-case>quot }
|
||||
{ $subsection distribute-buckets }
|
||||
{ $subsection hash-dispatch-quot } ;
|
||||
{ $subsection alist>quot } ;
|
||||
|
||||
ARTICLE: "combinators" "Additional combinators"
|
||||
"The " { $vocab-link "combinators" } " vocabulary is usually used because it provides two combinators which abstract out nested chains of " { $link if } ":"
|
||||
|
|
@ -104,19 +100,17 @@ HELP: case>quot
|
|||
{ $values { "assoc" "a sequence of pairs of quotations" } { "default" quotation } { "quot" quotation } }
|
||||
{ $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "."
|
||||
$nl
|
||||
"The quotation actually tests each possible case in order;" { $link hash-case>quot } " produces more efficient code." } ;
|
||||
"This word uses three strategies:"
|
||||
{ $list
|
||||
"If the assoc only has a few keys, a linear search is generated."
|
||||
{ "If the assoc has a large number of keys which form a contiguous range of integers, a direct dispatch is generated using the " { $link dispatch } " word together with a bounds check." }
|
||||
"Otherwise, an open-coded hashtable dispatch is generated."
|
||||
} } ;
|
||||
|
||||
HELP: distribute-buckets
|
||||
{ $values { "assoc" "an alist" } { "initial" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- assoc )" } } { "buckets" "a new array" } }
|
||||
{ $description "Sorts the entries of " { $snippet "assoc" } " into buckets, using the quotation to yield a set of keys for each entry. The hashcode of each key is computed, and the entry is placed in all corresponding buckets. Each bucket is initially cloned from " { $snippet "initial" } "; this should either be an empty vector or a one-element vector containing a pair." }
|
||||
{ $notes "This word is used in the implemention of " { $link hash-case>quot } " and " { $link standard-combination } "." } ;
|
||||
|
||||
HELP: hash-case>quot
|
||||
{ $values { "default" quotation } { "assoc" "an association list mapping quotations to quotations" } { "quot" quotation } }
|
||||
{ $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "."
|
||||
$nl
|
||||
"The quotation uses an efficient hash-based search to avoid testing the object against all possible keys." }
|
||||
{ $notes "This word is used behind the scenes to compile " { $link case } " forms efficiently; it can also be called directly, which is useful for meta-programming." } ;
|
||||
{ $notes "This word is used in the implemention of " { $link hash-case-quot } " and " { $link standard-combination } "." } ;
|
||||
|
||||
HELP: dispatch ( n array -- )
|
||||
{ $values { "n" "a fixnum" } { "array" "an array of quotations" } }
|
||||
|
|
|
|||
|
|
@ -69,3 +69,10 @@ namespaces combinators words ;
|
|||
|
||||
! Interpreted
|
||||
[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
|
||||
|
||||
[ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test
|
||||
[ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test
|
||||
[ f ] [ { + 3 2 } contiguous-range? 2nip ] unit-test
|
||||
[ f ] [ { 1 0 7 } contiguous-range? 2nip ] unit-test
|
||||
[ f ] [ { 1 1 3 7 } contiguous-range? 2nip ] unit-test
|
||||
[ 4 8 t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: combinators
|
||||
USING: arrays sequences sequences.private math.private
|
||||
kernel kernel.private math assocs quotations vectors ;
|
||||
kernel kernel.private math assocs quotations vectors
|
||||
hashtables sorting ;
|
||||
|
||||
TUPLE: no-cond ;
|
||||
|
||||
|
|
@ -31,16 +32,24 @@ TUPLE: no-case ;
|
|||
: recursive-hashcode ( n obj quot -- code )
|
||||
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
|
||||
|
||||
! These go here, not in sequences and hashtables, since those
|
||||
! two depend on combinators
|
||||
M: sequence hashcode*
|
||||
[ sequence-hashcode ] recursive-hashcode ;
|
||||
|
||||
M: hashtable hashcode*
|
||||
[
|
||||
dup assoc-size 1 number=
|
||||
[ assoc-hashcode ] [ nip assoc-size ] if
|
||||
] recursive-hashcode ;
|
||||
|
||||
: alist>quot ( default assoc -- quot )
|
||||
[ rot \ if 3array append [ ] like ] assoc-each ;
|
||||
|
||||
: cond>quot ( assoc -- quot )
|
||||
reverse [ no-cond ] swap alist>quot ;
|
||||
|
||||
: case>quot ( default assoc -- quot )
|
||||
: linear-case-quot ( default assoc -- quot )
|
||||
[ >r [ dupd = ] curry r> \ drop add* ] assoc-map
|
||||
alist>quot ;
|
||||
|
||||
|
|
@ -63,20 +72,50 @@ M: sequence hashcode*
|
|||
|
||||
: hash-case-table ( default assoc -- array )
|
||||
V{ } [ 1array ] distribute-buckets
|
||||
[ case>quot ] with map ;
|
||||
[ linear-case-quot ] with map ;
|
||||
|
||||
: hash-dispatch-quot ( table -- quot )
|
||||
[ length 1- [ fixnum-bitand ] curry ] keep
|
||||
[ dispatch ] curry append ;
|
||||
|
||||
: hash-case>quot ( default assoc -- quot )
|
||||
: hash-case-quot ( default assoc -- quot )
|
||||
hash-case-table hash-dispatch-quot
|
||||
[ dup hashcode >fixnum ] swap append ;
|
||||
|
||||
: contiguous-range? ( keys -- from to ? )
|
||||
dup [ fixnum? ] all? [
|
||||
dup all-unique? [
|
||||
dup infimum over supremum
|
||||
[ - swap prune length + 1 = ] 2keep rot
|
||||
] [
|
||||
drop f f f
|
||||
] if
|
||||
] [
|
||||
drop f f f
|
||||
] if ;
|
||||
|
||||
: dispatch-case ( value from to default array -- )
|
||||
>r >r 3dup between? [
|
||||
drop - >fixnum r> drop r> dispatch
|
||||
] [
|
||||
2drop r> call r> drop
|
||||
] if ; inline
|
||||
|
||||
: dispatch-case-quot ( default assoc from to -- quot )
|
||||
-roll -roll sort-keys values [ >quotation ] map
|
||||
[ dispatch-case ] 2curry 2curry ;
|
||||
|
||||
: case>quot ( default assoc -- quot )
|
||||
dup empty? [
|
||||
drop
|
||||
] [
|
||||
dup length 4 <= [
|
||||
case>quot
|
||||
linear-case-quot
|
||||
] [
|
||||
hash-case-table hash-dispatch-quot
|
||||
[ dup hashcode >fixnum ] swap append
|
||||
dup keys contiguous-range? [
|
||||
dispatch-case-quot
|
||||
] [
|
||||
2drop hash-case-quot
|
||||
] if
|
||||
] if
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: temporary
|
||||
USING: compiler tools.test namespaces sequences
|
||||
kernel.private kernel math continuations continuations.private
|
||||
words splitting ;
|
||||
words splitting sorting ;
|
||||
|
||||
: symbolic-stack-trace ( -- newseq )
|
||||
error-continuation get continuation-call callstack>array
|
||||
|
|
@ -31,9 +31,9 @@ words splitting ;
|
|||
\ > stack-trace-contains?
|
||||
] unit-test
|
||||
|
||||
: quux [ t [ "hi" throw ] when ] times ;
|
||||
: quux { 1 2 3 } [ "hi" throw ] sort ;
|
||||
|
||||
[ t ] [
|
||||
[ 10 quux ] ignore-errors
|
||||
\ (each-integer) stack-trace-contains?
|
||||
\ sort stack-trace-contains?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -44,7 +44,9 @@ words kernel math effects definitions compiler.units ;
|
|||
[
|
||||
[ ] [ init-templates ] unit-test
|
||||
|
||||
[ ] [ init-generator ] unit-test
|
||||
H{ } clone compiled set
|
||||
|
||||
[ ] [ gensym gensym begin-compiling ] unit-test
|
||||
|
||||
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel kernel.private slots.private math assocs
|
||||
math.private sequences sequences.private vectors
|
||||
combinators ;
|
||||
math.private sequences sequences.private vectors ;
|
||||
IN: hashtables
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -161,17 +160,10 @@ M: hashtable clone
|
|||
(clone) dup hash-array clone over set-hash-array ;
|
||||
|
||||
M: hashtable equal?
|
||||
{
|
||||
{ [ over hashtable? not ] [ 2drop f ] }
|
||||
{ [ 2dup [ assoc-size ] 2apply number= not ] [ 2drop f ] }
|
||||
{ [ t ] [ assoc= ] }
|
||||
} cond ;
|
||||
|
||||
M: hashtable hashcode*
|
||||
[
|
||||
dup assoc-size 1 number=
|
||||
[ assoc-hashcode ] [ nip assoc-size ] if
|
||||
] recursive-hashcode ;
|
||||
over hashtable? [
|
||||
2dup [ assoc-size ] 2apply number=
|
||||
[ assoc= ] [ 2drop f ] if
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
! Default method
|
||||
M: assoc new-assoc drop <hashtable> ;
|
||||
|
|
|
|||
|
|
@ -314,7 +314,7 @@ PREDICATE: #merge #tail-merge node-successor #tail? ;
|
|||
PREDICATE: #values #tail-values node-successor #tail? ;
|
||||
|
||||
UNION: #tail
|
||||
POSTPONE: f #return #tail-values #tail-merge ;
|
||||
POSTPONE: f #return #tail-values #tail-merge #terminate ;
|
||||
|
||||
: tail-call? ( -- ? )
|
||||
node-stack get [ node-successor #tail? ] all? ;
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@ IN: inference.transforms
|
|||
dup peek swap 1 head*
|
||||
] [
|
||||
[ no-case ] swap
|
||||
] if hash-case>quot
|
||||
] if case>quot
|
||||
] if
|
||||
] 1 define-transform
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
USING: help.syntax help.markup ;
|
||||
IN: io.encodings.binary
|
||||
|
||||
HELP: binary
|
||||
{ $class-description "This is the encoding descriptor for binary I/O." } ;
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
USING: kernel io.encodings ;
|
||||
|
||||
TUPLE: binary ;
|
||||
|
||||
M: binary init-decoding drop ;
|
||||
M: binary init-encoding drop ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Dummy encoding for binary I/O
|
||||
|
|
@ -0,0 +1 @@
|
|||
text
|
||||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel sequences sbufs vectors
|
||||
namespaces unicode.syntax ;
|
||||
USING: math kernel sequences sbufs vectors io.streams.lines io.streams.plain
|
||||
namespaces unicode.syntax growable strings io classes io.streams.c
|
||||
continuations ;
|
||||
IN: io.encodings
|
||||
|
||||
TUPLE: encode-error ;
|
||||
|
|
@ -23,6 +24,72 @@ SYMBOL: begin
|
|||
: finish-decoding ( buf ch state -- str )
|
||||
begin eq? [ decode-error ] unless drop "" like ;
|
||||
|
||||
: decode ( seq quot -- str )
|
||||
>r [ length <sbuf> 0 begin ] keep r> each
|
||||
: start-decoding ( seq length -- buf ch state seq )
|
||||
<sbuf> 0 begin roll ;
|
||||
|
||||
GENERIC: decode-step ( buf byte ch state encoding -- buf ch state )
|
||||
|
||||
: decode ( seq quot -- string )
|
||||
>r dup length start-decoding r>
|
||||
[ -rot ] swap compose each
|
||||
finish-decoding ; inline
|
||||
|
||||
: space ( resizable -- room-left )
|
||||
dup underlying swap [ length ] 2apply - ;
|
||||
|
||||
: full? ( resizable -- ? ) space zero? ;
|
||||
|
||||
: end-read-loop ( buf ch state stream quot -- string/f )
|
||||
2drop 2drop >string f like ;
|
||||
|
||||
: decode-read-loop ( buf ch state stream encoding -- string/f )
|
||||
>r >r pick r> r> rot full? [ end-read-loop ] [
|
||||
over stream-read1 [
|
||||
-rot tuck >r >r >r -rot r> decode-step r> r> decode-read-loop
|
||||
] [ end-read-loop ] if*
|
||||
] if ;
|
||||
|
||||
: decode-read ( length stream encoding -- string )
|
||||
>r swap start-decoding r>
|
||||
decode-read-loop ;
|
||||
|
||||
GENERIC: init-decoding ( stream encoding -- decoded-stream )
|
||||
|
||||
: <decoding> ( stream decoding-class -- decoded-stream )
|
||||
construct-empty init-decoding <line-reader> ;
|
||||
|
||||
GENERIC: init-encoding ( stream encoding -- encoded-stream )
|
||||
|
||||
: <encoding> ( stream encoding-class -- encoded-stream )
|
||||
construct-empty init-encoding <plain-writer> ;
|
||||
|
||||
GENERIC: encode-string ( string encoding -- byte-array )
|
||||
M: tuple-class encode-string construct-empty encode-string ;
|
||||
|
||||
MIXIN: encoding-stream
|
||||
|
||||
M: encoding-stream init-decoding ( stream encoding-stream -- encoding-stream )
|
||||
tuck set-delegate ;
|
||||
|
||||
M: encoding-stream init-encoding ( stream encoding-stream -- encoding-stream )
|
||||
tuck set-delegate ;
|
||||
|
||||
M: encoding-stream stream-read1 1 swap stream-read ;
|
||||
|
||||
M: encoding-stream stream-read
|
||||
[ delegate ] keep decode-read ;
|
||||
|
||||
M: encoding-stream stream-read-partial stream-read ;
|
||||
|
||||
M: encoding-stream stream-read-until
|
||||
! Copied from { c-reader stream-read-until }!!!
|
||||
[ swap read-until-loop ] "" make
|
||||
swap over empty? over not and [ 2drop f f ] when ;
|
||||
|
||||
M: encoding-stream stream-write1
|
||||
>r 1string r> stream-write ;
|
||||
|
||||
M: encoding-stream stream-write
|
||||
[ encode-string ] keep delegate stream-write ;
|
||||
|
||||
M: encoding-stream dispose delegate dispose ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
USING: help.syntax help.markup ;
|
||||
IN: io.encodings.latin1
|
||||
|
||||
HELP: latin1
|
||||
{ $class-description "This class is used for Latin 1 (ISO 8859-1) encoding and decoding" } ;
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
USING: io io.encodings strings kernel ;
|
||||
IN: io.encodings.latin1
|
||||
|
||||
TUPLE: latin1 stream ;
|
||||
|
||||
M: latin1 init-decoding tuck set-latin1-stream ;
|
||||
M: latin1 init-encoding drop ;
|
||||
|
||||
M: latin1 stream-read1
|
||||
latin1-stream stream-read1 ;
|
||||
|
||||
M: latin1 stream-read
|
||||
latin1-stream stream-read >string ;
|
||||
|
||||
M: latin1 stream-read-until
|
||||
latin1-stream stream-read-until >string ;
|
||||
|
||||
M: latin1 stream-readln
|
||||
latin1-stream stream-readln >string ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
ISO 8859-1 encoding/decoding
|
||||
|
|
@ -0,0 +1 @@
|
|||
text
|
||||
Binary file not shown.
|
|
@ -0,0 +1 @@
|
|||
Daniel Ehrenberg
|
||||
|
|
@ -0,0 +1 @@
|
|||
text
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax io.encodings strings ;
|
||||
IN: io.utf16
|
||||
IN: io.encodings.utf16
|
||||
|
||||
ARTICLE: "io.utf16" "Working with UTF16-encoded data"
|
||||
"The UTF16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences."
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel sequences sbufs vectors namespaces io.binary
|
||||
io.encodings combinators splitting ;
|
||||
IN: io.utf16
|
||||
IN: io.encodings.utf16
|
||||
|
||||
SYMBOL: double
|
||||
SYMBOL: quad1
|
||||
|
|
@ -30,7 +30,7 @@ SYMBOL: ignore
|
|||
>r 2 shift r> BIN: 11 bitand bitor quad3
|
||||
] [ 2drop do-ignore ] if ;
|
||||
|
||||
: (decode-utf16be) ( buf byte ch state -- buf ch state )
|
||||
: decode-utf16be-step ( buf byte ch state -- buf ch state )
|
||||
{
|
||||
{ begin [ drop begin-utf16be ] }
|
||||
{ double [ end-multibyte ] }
|
||||
|
|
@ -41,7 +41,7 @@ SYMBOL: ignore
|
|||
} case ;
|
||||
|
||||
: decode-utf16be ( seq -- str )
|
||||
[ -rot (decode-utf16be) ] decode ;
|
||||
[ decode-utf16be-step ] decode ;
|
||||
|
||||
: handle-double ( buf byte ch -- buf ch state )
|
||||
swap dup -3 shift BIN: 11011 = [
|
||||
|
|
@ -55,7 +55,7 @@ SYMBOL: ignore
|
|||
BIN: 11 bitand append-nums HEX: 10000 + decoded
|
||||
] [ 2drop push-replacement ] if ;
|
||||
|
||||
: (decode-utf16le) ( buf byte ch state -- buf ch state )
|
||||
: decode-utf16le-step ( buf byte ch state -- buf ch state )
|
||||
{
|
||||
{ begin [ drop double ] }
|
||||
{ double [ handle-double ] }
|
||||
|
|
@ -65,7 +65,7 @@ SYMBOL: ignore
|
|||
} case ;
|
||||
|
||||
: decode-utf16le ( seq -- str )
|
||||
[ -rot (decode-utf16le) ] decode ;
|
||||
[ decode-utf16le-step ] decode ;
|
||||
|
||||
: encode-first
|
||||
-10 shift
|
||||
|
|
@ -104,13 +104,23 @@ SYMBOL: ignore
|
|||
: encode-utf16 ( str -- seq )
|
||||
encode-utf16le bom-le swap append ;
|
||||
|
||||
: utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
|
||||
|
||||
: utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
|
||||
|
||||
: decode-utf16 ( seq -- str )
|
||||
{
|
||||
{ [ utf16le? ] [ decode-utf16le ] }
|
||||
{ [ utf16be? ] [ decode-utf16be ] }
|
||||
{ [ bom-le ?head ] [ decode-utf16le ] }
|
||||
{ [ bom-be ?head ] [ decode-utf16be ] }
|
||||
{ [ t ] [ decode-error ] }
|
||||
} cond ;
|
||||
|
||||
TUPLE: utf16le ;
|
||||
: <utf16le> utf16le construct-delegate ;
|
||||
INSTANCE: utf16le encoding-stream
|
||||
|
||||
M: utf16le encode-string drop encode-utf16le ;
|
||||
M: utf16le decode-step drop decode-utf16le-step ;
|
||||
|
||||
TUPLE: utf16be ;
|
||||
: <utf16be> utf16be construct-delegate ;
|
||||
INSTANCE: utf16be encoding-stream
|
||||
|
||||
M: utf16be encode-string drop encode-utf16be ;
|
||||
M: utf16be decode-step drop decode-utf16be-step ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Daniel Ehrenberg
|
||||
|
|
@ -0,0 +1 @@
|
|||
text
|
||||
6
core/io/utf8/utf8-docs.factor → core/io/encodings/utf8/utf8-docs.factor
Normal file → Executable file
6
core/io/utf8/utf8-docs.factor → core/io/encodings/utf8/utf8-docs.factor
Normal file → Executable file
|
|
@ -1,12 +1,12 @@
|
|||
USING: help.markup help.syntax io.encodings strings ;
|
||||
IN: io.utf8
|
||||
IN: io.encodings.utf8
|
||||
|
||||
ARTICLE: "io.utf8" "Working with UTF8-encoded data"
|
||||
ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data"
|
||||
"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences."
|
||||
{ $subsection encode-utf8 }
|
||||
{ $subsection decode-utf8 } ;
|
||||
|
||||
ABOUT: "io.utf8"
|
||||
ABOUT: "io.encodings.utf8"
|
||||
|
||||
HELP: decode-utf8
|
||||
{ $values { "seq" "a sequence of bytes" } { "str" string } }
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
USING: io.encodings.utf8 tools.test sbufs kernel io
|
||||
sequences strings arrays unicode.syntax ;
|
||||
|
||||
: decode-utf8-w/stream ( array -- newarray )
|
||||
>sbuf dup reverse-here <utf8> contents >array ;
|
||||
|
||||
: encode-utf8-w/stream ( array -- newarray )
|
||||
SBUF" " clone tuck <utf8> write >array ;
|
||||
|
||||
[ { UNICHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test
|
||||
|
||||
[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
|
||||
|
||||
[ "x" ] [ "x" decode-utf8-w/stream >string ] unit-test
|
||||
|
||||
[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
|
||||
|
||||
[ { UNICHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
|
||||
|
||||
[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
|
||||
|
||||
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
|
||||
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8 ] unit-test
|
||||
|
|
@ -1,8 +1,10 @@
|
|||
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel sequences sbufs vectors
|
||||
namespaces io.encodings combinators ;
|
||||
IN: io.utf8
|
||||
USING: math kernel sequences sbufs vectors growable io continuations
|
||||
namespaces io.encodings combinators strings io.streams.c ;
|
||||
IN: io.encodings.utf8
|
||||
|
||||
! Decoding UTF-8
|
||||
|
||||
SYMBOL: double
|
||||
SYMBOL: triple
|
||||
|
|
@ -31,7 +33,7 @@ SYMBOL: quad3
|
|||
: end-multibyte ( buf byte ch -- buf ch state )
|
||||
f append-nums [ decoded ] unless* ;
|
||||
|
||||
: (decode-utf8) ( buf byte ch state -- buf ch state )
|
||||
: decode-utf8-step ( buf byte ch state -- buf ch state )
|
||||
{
|
||||
{ begin [ drop begin-utf8 ] }
|
||||
{ double [ end-multibyte ] }
|
||||
|
|
@ -43,7 +45,9 @@ SYMBOL: quad3
|
|||
} case ;
|
||||
|
||||
: decode-utf8 ( seq -- str )
|
||||
[ -rot (decode-utf8) ] decode ;
|
||||
[ decode-utf8-step ] decode ;
|
||||
|
||||
! Encoding UTF-8
|
||||
|
||||
: encoded ( char -- )
|
||||
BIN: 111111 bitand BIN: 10000000 bitor , ;
|
||||
|
|
@ -70,3 +74,13 @@ SYMBOL: quad3
|
|||
|
||||
: encode-utf8 ( str -- seq )
|
||||
[ [ char>utf8 ] each ] B{ } make ;
|
||||
|
||||
! Interface for streams
|
||||
|
||||
TUPLE: utf8 ;
|
||||
: <utf8> utf8 construct-delegate ;
|
||||
INSTANCE: utf8 encoding-stream
|
||||
|
||||
M: utf8 encode-string drop encode-utf8 ;
|
||||
M: utf8 decode-step drop decode-utf8-step ;
|
||||
! In the future, this should detect and ignore a BOM at the beginning
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
USING: io.utf8 tools.test strings arrays unicode.syntax ;
|
||||
|
||||
[ { UNICHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8 >array ] unit-test
|
||||
|
||||
[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8 >array ] unit-test
|
||||
|
||||
[ "x" ] [ "x" decode-utf8 >string ] unit-test
|
||||
|
||||
[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8 >array ] unit-test
|
||||
|
||||
[ { UNICHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8 >array ] unit-test
|
||||
|
||||
[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8 >array ] unit-test
|
||||
|
||||
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
|
||||
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8 ] unit-test
|
||||
|
|
@ -3,8 +3,7 @@
|
|||
USING: arrays generic assocs inference inference.class
|
||||
inference.dataflow inference.backend inference.state io kernel
|
||||
math namespaces sequences vectors words quotations hashtables
|
||||
combinators classes generic.math continuations optimizer.def-use
|
||||
optimizer.pattern-match generic.standard optimizer.specializers ;
|
||||
combinators classes optimizer.def-use ;
|
||||
IN: optimizer.backend
|
||||
|
||||
SYMBOL: class-substitutions
|
||||
|
|
@ -68,8 +67,6 @@ DEFER: optimize-nodes
|
|||
] if
|
||||
] when ;
|
||||
|
||||
M: f set-node-successor 2drop ;
|
||||
|
||||
: optimize-nodes ( node -- newnode )
|
||||
[
|
||||
class-substitutions [ clone ] change
|
||||
|
|
@ -78,19 +75,9 @@ M: f set-node-successor 2drop ;
|
|||
optimizer-changed get
|
||||
] with-scope optimizer-changed set ;
|
||||
|
||||
! Generic nodes
|
||||
M: node optimize-node* drop t f ;
|
||||
|
||||
: cleanup-inlining ( node -- newnode changed? )
|
||||
node-successor [ node-successor t ] [ t f ] if* ;
|
||||
|
||||
! #return
|
||||
M: #return optimize-node* cleanup-inlining ;
|
||||
|
||||
! #values
|
||||
M: #values optimize-node* cleanup-inlining ;
|
||||
|
||||
! Some utilities for splicing in dataflow IR subtrees
|
||||
! Post-inlining cleanup
|
||||
: follow ( key assoc -- value )
|
||||
2dup at* [ swap follow nip ] [ 2drop ] if ;
|
||||
|
||||
|
|
@ -103,282 +90,30 @@ M: #values optimize-node* cleanup-inlining ;
|
|||
#! Not very efficient.
|
||||
dupd union* update ;
|
||||
|
||||
: post-inline ( #call/#merge #return/#values -- assoc )
|
||||
>r node-out-d r> node-in-d 2array unify-lengths flip
|
||||
: compute-value-substitutions ( #return/#values #call/#merge -- assoc )
|
||||
node-out-d swap node-in-d 2array unify-lengths flip
|
||||
[ = not ] assoc-subset >hashtable ;
|
||||
|
||||
: substitute-def-use ( node -- )
|
||||
#! As a first approximation, we take all the values used
|
||||
#! by the set of new nodes, and push a 't' on their
|
||||
#! def-use list here. We could perform a full graph
|
||||
#! substitution, but we don't need to, because the next
|
||||
#! optimizer iteration will do that. We just need a minimal
|
||||
#! degree of accuracy; the new values should be marked as
|
||||
#! having _some_ usage, so that flushing doesn't erronously
|
||||
#! flush them away.
|
||||
[ compute-def-use def-use get keys ] with-scope
|
||||
def-use get [ [ t swap ?push ] change-at ] curry each ;
|
||||
: cleanup-inlining ( #return/#values -- newnode changed? )
|
||||
dup node-successor dup [
|
||||
class-substitutions get pick node-classes update
|
||||
literal-substitutions get pick node-literals update
|
||||
tuck compute-value-substitutions value-substitutions get swap update*
|
||||
node-successor t
|
||||
] [
|
||||
2drop t f
|
||||
] if ;
|
||||
|
||||
: substitute-node ( old new -- )
|
||||
#! The last node of 'new' becomes 'old', then values are
|
||||
#! substituted. A subsequent optimizer phase kills the
|
||||
#! last node of 'new' and the first node of 'old'.
|
||||
dup substitute-def-use
|
||||
last-node
|
||||
class-substitutions get over node-classes update
|
||||
literal-substitutions get over node-literals update
|
||||
2dup post-inline value-substitutions get swap update*
|
||||
set-node-successor ;
|
||||
! #return
|
||||
M: #return optimize-node* cleanup-inlining ;
|
||||
|
||||
GENERIC: remember-method* ( method-spec node -- )
|
||||
! #values
|
||||
M: #values optimize-node* cleanup-inlining ;
|
||||
|
||||
M: #call remember-method*
|
||||
[ node-history ?push ] keep set-node-history ;
|
||||
M: f set-node-successor 2drop ;
|
||||
|
||||
M: node remember-method*
|
||||
2drop ;
|
||||
|
||||
: remember-method ( method-spec node -- )
|
||||
swap dup second +inlined+ depends-on
|
||||
[ swap remember-method* ] curry each-node ;
|
||||
|
||||
: (splice-method) ( #call method-spec quot -- node )
|
||||
#! Must remember the method before splicing in, otherwise
|
||||
#! the rest of the IR will also remember the method
|
||||
pick node-in-d dataflow-with
|
||||
[ remember-method ] keep
|
||||
[ swap infer-classes/node ] 2keep
|
||||
[ substitute-node ] keep ;
|
||||
|
||||
: splice-quot ( #call quot -- node )
|
||||
over node-in-d dataflow-with
|
||||
[ swap infer-classes/node ] 2keep
|
||||
[ substitute-node ] keep ;
|
||||
: splice-node ( old new -- )
|
||||
dup splice-def-use last-node set-node-successor ;
|
||||
|
||||
: drop-inputs ( node -- #shuffle )
|
||||
node-in-d clone \ #shuffle in-node ;
|
||||
|
||||
! Constant branch folding
|
||||
: fold-branch ( node branch# -- node )
|
||||
over node-children nth
|
||||
swap node-successor over substitute-node ;
|
||||
|
||||
! #if
|
||||
: known-boolean-value? ( node value -- value ? )
|
||||
2dup node-literal? [
|
||||
node-literal t
|
||||
] [
|
||||
node-class {
|
||||
{ [ dup null class< ] [ drop f f ] }
|
||||
{ [ dup general-t class< ] [ drop t t ] }
|
||||
{ [ dup \ f class< ] [ drop f t ] }
|
||||
{ [ t ] [ drop f f ] }
|
||||
} cond
|
||||
] if ;
|
||||
|
||||
M: #if optimize-node*
|
||||
dup dup node-in-d first known-boolean-value? [
|
||||
over drop-inputs >r
|
||||
0 1 ? fold-branch
|
||||
r> [ set-node-successor ] keep
|
||||
t
|
||||
] [ 2drop t f ] if ;
|
||||
|
||||
M: #dispatch optimize-node*
|
||||
dup dup node-in-d first 2dup node-literal? [
|
||||
"Optimizing #dispatch" print
|
||||
node-literal
|
||||
over drop-inputs >r fold-branch r> [ set-node-successor ] keep t
|
||||
] [
|
||||
3drop t f
|
||||
] if ;
|
||||
|
||||
! #call
|
||||
: splice-method ( #call method-spec/t quot/t -- node/t )
|
||||
#! t indicates failure
|
||||
{
|
||||
{ [ dup t eq? ] [ 3drop t ] }
|
||||
{ [ 2over swap node-history member? ] [ 3drop t ] }
|
||||
{ [ t ] [ (splice-method) ] }
|
||||
} cond ;
|
||||
|
||||
! Single dispatch method inlining optimization
|
||||
: already-inlined? ( node -- ? )
|
||||
#! Was this node inlined from definition of 'word'?
|
||||
dup node-param swap node-history memq? ;
|
||||
|
||||
: specific-method ( class word -- class ) order min-class ;
|
||||
|
||||
: node-class# ( node n -- class )
|
||||
over node-in-d <reversed> ?nth node-class ;
|
||||
|
||||
: dispatching-class ( node word -- class )
|
||||
[ dispatch# node-class# ] keep specific-method ;
|
||||
|
||||
! A heuristic to avoid excessive inlining
|
||||
DEFER: (flat-length)
|
||||
|
||||
: word-flat-length ( word -- n )
|
||||
dup get over inline? not or
|
||||
[ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
|
||||
|
||||
: (flat-length) ( seq -- n )
|
||||
[
|
||||
{
|
||||
{ [ dup quotation? ] [ (flat-length) 1+ ] }
|
||||
{ [ dup array? ] [ (flat-length) ] }
|
||||
{ [ dup word? ] [ word-flat-length ] }
|
||||
{ [ t ] [ drop 1 ] }
|
||||
} cond
|
||||
] map sum ;
|
||||
|
||||
: flat-length ( seq -- n )
|
||||
[ word-def (flat-length) ] with-scope ;
|
||||
|
||||
: will-inline-method ( node word -- method-spec/t quot/t )
|
||||
#! t indicates failure
|
||||
tuck dispatching-class dup [
|
||||
swap [ 2array ] 2keep
|
||||
method method-word
|
||||
dup flat-length 10 >=
|
||||
[ 1quotation ] [ word-def ] if
|
||||
] [
|
||||
2drop t t
|
||||
] if ;
|
||||
|
||||
: inline-standard-method ( node word -- node )
|
||||
dupd will-inline-method splice-method ;
|
||||
|
||||
! Partial dispatch of math-generic words
|
||||
: math-both-known? ( word left right -- ? )
|
||||
math-class-max swap specific-method ;
|
||||
|
||||
: will-inline-math-method ( word left right -- method-spec/t quot/t )
|
||||
#! t indicates failure
|
||||
3dup math-both-known?
|
||||
[ [ 3array ] 3keep math-method ] [ 3drop t t ] if ;
|
||||
|
||||
: inline-math-method ( #call word -- node )
|
||||
over node-input-classes first2
|
||||
will-inline-math-method splice-method ;
|
||||
|
||||
: inline-method ( #call -- node )
|
||||
dup node-param {
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
{ [ t ] [ 2drop t ] }
|
||||
} cond ;
|
||||
|
||||
! Resolve type checks at compile time where possible
|
||||
: comparable? ( actual testing -- ? )
|
||||
#! If actual is a subset of testing or if the two classes
|
||||
#! are disjoint, return t.
|
||||
2dup class< >r classes-intersect? not r> or ;
|
||||
|
||||
: optimize-predicate? ( #call -- ? )
|
||||
dup node-param "predicating" word-prop dup [
|
||||
>r node-class-first r> comparable?
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: literal-quot ( node literals -- quot )
|
||||
#! Outputs a quotation which drops the node's inputs, and
|
||||
#! pushes some literals.
|
||||
>r node-in-d length \ drop <repetition>
|
||||
r> [ literalize ] map append >quotation ;
|
||||
|
||||
: inline-literals ( node literals -- node )
|
||||
#! Make #shuffle -> #push -> #return -> successor
|
||||
dupd literal-quot splice-quot ;
|
||||
|
||||
: evaluate-predicate ( #call -- ? )
|
||||
dup node-param "predicating" word-prop >r
|
||||
node-class-first r> class< ;
|
||||
|
||||
: optimize-predicate ( #call -- node )
|
||||
dup evaluate-predicate swap
|
||||
dup node-successor #if? [
|
||||
dup drop-inputs >r
|
||||
node-successor swap 0 1 ? fold-branch
|
||||
r> [ set-node-successor ] keep
|
||||
] [
|
||||
swap 1array inline-literals
|
||||
] if ;
|
||||
|
||||
: optimizer-hooks ( node -- conditions )
|
||||
node-param "optimizer-hooks" word-prop ;
|
||||
|
||||
: optimizer-hook ( node -- pair/f )
|
||||
dup optimizer-hooks [ first call ] find 2nip ;
|
||||
|
||||
: optimize-hook ( node -- )
|
||||
dup optimizer-hook second call ;
|
||||
|
||||
: define-optimizers ( word optimizers -- )
|
||||
"optimizer-hooks" set-word-prop ;
|
||||
|
||||
: flush-eval? ( #call -- ? )
|
||||
dup node-param "flushable" word-prop [
|
||||
node-out-d [ unused? ] all?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: flush-eval ( #call -- node )
|
||||
dup node-param +inlined+ depends-on
|
||||
dup node-out-d length f <repetition> inline-literals ;
|
||||
|
||||
: partial-eval? ( #call -- ? )
|
||||
dup node-param "foldable" word-prop [
|
||||
dup node-in-d [ node-literal? ] with all?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: literal-in-d ( #call -- inputs )
|
||||
dup node-in-d [ node-literal ] with map ;
|
||||
|
||||
: partial-eval ( #call -- node )
|
||||
dup node-param +inlined+ depends-on
|
||||
dup literal-in-d over node-param 1quotation
|
||||
[ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
|
||||
|
||||
: define-identities ( words identities -- )
|
||||
[ "identities" set-word-prop ] curry each ;
|
||||
|
||||
: find-identity ( node -- quot )
|
||||
[ node-param "identities" word-prop ] keep
|
||||
[ swap first in-d-match? ] curry find
|
||||
nip dup [ second ] when ;
|
||||
|
||||
: apply-identities ( node -- node/f )
|
||||
dup find-identity dup [ splice-quot ] [ 2drop f ] if ;
|
||||
|
||||
: optimistic-inline? ( #call -- ? )
|
||||
dup node-param "specializer" word-prop dup [
|
||||
>r node-input-classes r> specialized-length tail*
|
||||
[ types length 1 = ] all?
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: optimistic-inline ( #call -- node )
|
||||
dup node-param dup +inlined+ depends-on
|
||||
word-def splice-quot ;
|
||||
|
||||
: method-body-inline? ( #call -- ? )
|
||||
node-param dup method-body?
|
||||
[ flat-length 8 <= ] [ drop f ] if ;
|
||||
|
||||
M: #call optimize-node*
|
||||
{
|
||||
{ [ dup flush-eval? ] [ flush-eval ] }
|
||||
{ [ dup partial-eval? ] [ partial-eval ] }
|
||||
{ [ dup find-identity ] [ apply-identities ] }
|
||||
{ [ dup optimizer-hook ] [ optimize-hook ] }
|
||||
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
|
||||
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
|
||||
{ [ dup method-body-inline? ] [ optimistic-inline ] }
|
||||
{ [ t ] [ inline-method ] }
|
||||
} cond dup not ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,60 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel inference.dataflow combinators sequences
|
||||
namespaces math ;
|
||||
USING: arrays generic assocs inference inference.class
|
||||
inference.dataflow inference.backend inference.state io kernel
|
||||
math namespaces sequences vectors words quotations hashtables
|
||||
combinators classes generic.math continuations optimizer.def-use
|
||||
optimizer.backend generic.standard ;
|
||||
IN: optimizer.control
|
||||
|
||||
! ! ! Loop detection
|
||||
|
||||
! A LOOP
|
||||
!
|
||||
! #label A
|
||||
! |
|
||||
! #if ----> #merge ----> #return
|
||||
! |
|
||||
! -------------
|
||||
! | |
|
||||
! #call-label A |
|
||||
! | ...
|
||||
! #values
|
||||
!
|
||||
! NOT A LOOP (call to A not in tail position):
|
||||
!
|
||||
!
|
||||
! #label A
|
||||
! |
|
||||
! #if ----> ... ----> #merge ----> #return
|
||||
! |
|
||||
! -------------
|
||||
! | |
|
||||
! #call-label A |
|
||||
! | ...
|
||||
! ...
|
||||
! |
|
||||
! #values
|
||||
!
|
||||
! NOT A LOOP (call to A nested inside another label/loop):
|
||||
!
|
||||
!
|
||||
! #label A
|
||||
! |
|
||||
! #if ----> #merge ----> ... ----> #return
|
||||
! |
|
||||
! -------------
|
||||
! | |
|
||||
! ... #label B
|
||||
! |
|
||||
! #if -> ...
|
||||
! |
|
||||
! ---------
|
||||
! | |
|
||||
! #call-label A |
|
||||
! | |
|
||||
! ... ...
|
||||
|
||||
GENERIC: detect-loops* ( node -- )
|
||||
|
||||
M: node detect-loops* drop ;
|
||||
|
|
@ -34,3 +85,201 @@ M: #call-label detect-loops*
|
|||
|
||||
: detect-loops ( node -- )
|
||||
[ detect-loops* ] each-node ;
|
||||
|
||||
! ! ! Constant branch folding
|
||||
!
|
||||
! BEFORE
|
||||
!
|
||||
! #if ----> #merge ----> C
|
||||
! |
|
||||
! ---------
|
||||
! | |
|
||||
! A B
|
||||
! | |
|
||||
! #values |
|
||||
! #values
|
||||
!
|
||||
! AFTER
|
||||
!
|
||||
! |
|
||||
! A
|
||||
! |
|
||||
! #values
|
||||
! |
|
||||
! #merge
|
||||
! |
|
||||
! C
|
||||
|
||||
: fold-branch ( node branch# -- node )
|
||||
over node-children nth
|
||||
swap node-successor over splice-node ;
|
||||
|
||||
! #if
|
||||
: known-boolean-value? ( node value -- value ? )
|
||||
2dup node-literal? [
|
||||
node-literal t
|
||||
] [
|
||||
node-class {
|
||||
{ [ dup null class< ] [ drop f f ] }
|
||||
{ [ dup general-t class< ] [ drop t t ] }
|
||||
{ [ dup \ f class< ] [ drop f t ] }
|
||||
{ [ t ] [ drop f f ] }
|
||||
} cond
|
||||
] if ;
|
||||
|
||||
: fold-if-branch? dup node-in-d first known-boolean-value? ;
|
||||
|
||||
: fold-if-branch ( node value -- node' )
|
||||
over drop-inputs >r
|
||||
0 1 ? fold-branch
|
||||
r> [ set-node-successor ] keep ;
|
||||
|
||||
! ! ! Lifting code after a conditional if one branch throws
|
||||
: only-one ( seq -- elt/f )
|
||||
dup length 1 = [ first ] [ drop f ] if ;
|
||||
|
||||
: lift-throw-tail? ( #if -- tail/? )
|
||||
dup node-successor #tail?
|
||||
[ drop f ] [ active-children only-one ] if ;
|
||||
|
||||
: clone-node ( node -- newnode )
|
||||
clone dup [ clone ] modify-values ;
|
||||
|
||||
! BEFORE
|
||||
!
|
||||
! #if ----> #merge ----> B ----> #return/#values
|
||||
! |
|
||||
! |
|
||||
! ---------
|
||||
! | |
|
||||
! | A
|
||||
! #terminate |
|
||||
! #values
|
||||
!
|
||||
! AFTER
|
||||
!
|
||||
! #if ----> #merge (*) ----> #return/#values (**)
|
||||
! |
|
||||
! |
|
||||
! ---------
|
||||
! | |
|
||||
! | A
|
||||
! #terminate |
|
||||
! #values
|
||||
! |
|
||||
! #merge (***)
|
||||
! |
|
||||
! B
|
||||
! |
|
||||
! #return/#values
|
||||
!
|
||||
! (*) has the same outputs as the inputs of (**), and it is not
|
||||
! the same node as (***)
|
||||
!
|
||||
! Note: if (**) is #return is is sound to put #terminate there,
|
||||
! but not if (**) is #values
|
||||
|
||||
: lift-branch
|
||||
over
|
||||
last-node clone-node
|
||||
dup node-in-d \ #merge out-node
|
||||
[ set-node-successor ] keep -rot
|
||||
>r dup node-successor r> splice-node
|
||||
set-node-successor ;
|
||||
|
||||
M: #if optimize-node*
|
||||
dup fold-if-branch? [ fold-if-branch t ] [
|
||||
drop dup lift-throw-tail? dup [
|
||||
dupd lift-branch t
|
||||
] [
|
||||
2drop t f
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: fold-dispatch-branch? dup node-in-d first tuck node-literal? ;
|
||||
|
||||
: fold-dispatch-branch ( node value -- node' )
|
||||
dupd node-literal
|
||||
over drop-inputs >r fold-branch r>
|
||||
[ set-node-successor ] keep ;
|
||||
|
||||
M: #dispatch optimize-node*
|
||||
dup fold-dispatch-branch? [
|
||||
fold-dispatch-branch t
|
||||
] [
|
||||
2drop t f
|
||||
] if ;
|
||||
|
||||
! Loop tail hoising: code after a loop can sometimes go in the
|
||||
! non-recursive branch of the loop
|
||||
|
||||
! BEFORE:
|
||||
|
||||
! #label -> C -> #return 1
|
||||
! |
|
||||
! -> #if -> #merge -> #return 2
|
||||
! |
|
||||
! --------
|
||||
! | |
|
||||
! A B
|
||||
! | |
|
||||
! #values |
|
||||
! #call-label
|
||||
! |
|
||||
! |
|
||||
! #values
|
||||
|
||||
! AFTER:
|
||||
|
||||
! #label -> #terminate
|
||||
! |
|
||||
! -> #if -> #terminate
|
||||
! |
|
||||
! --------
|
||||
! | |
|
||||
! A B
|
||||
! | |
|
||||
! #values |
|
||||
! | #call-label
|
||||
! #merge |
|
||||
! | |
|
||||
! C #values
|
||||
! |
|
||||
! #return 1
|
||||
|
||||
: find-final-if ( node -- #if/f )
|
||||
dup [
|
||||
dup #if? [
|
||||
dup node-successor #tail? [
|
||||
node-successor find-final-if
|
||||
] unless
|
||||
] [
|
||||
node-successor find-final-if
|
||||
] if
|
||||
] when ;
|
||||
|
||||
: detach-node-successor ( node -- successor )
|
||||
dup node-successor #terminate rot set-node-successor ;
|
||||
|
||||
: lift-loop-tail? ( #label -- tail/f )
|
||||
dup node-successor node-successor [
|
||||
dup node-param swap node-child find-final-if dup [
|
||||
node-children [ penultimate-node ] map
|
||||
[
|
||||
dup #call-label?
|
||||
[ node-param eq? not ] [ 2drop t ] if
|
||||
] with subset only-one
|
||||
] [ 2drop f ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
! M: #loop optimize-node*
|
||||
! dup lift-loop-tail? dup [
|
||||
! last-node >r
|
||||
! dup detach-node-successor
|
||||
! over node-child find-final-if detach-node-successor
|
||||
! [ set-node-successor ] keep
|
||||
! r> set-node-successor
|
||||
! t
|
||||
! ] [
|
||||
! 2drop t f
|
||||
! ] if ;
|
||||
|
|
|
|||
|
|
@ -70,20 +70,6 @@ M: #branch node-def-use
|
|||
#! #values node.
|
||||
dup branch-def-use (node-def-use) ;
|
||||
|
||||
! : dead-literals ( -- values )
|
||||
! def-use get [ >r value? r> empty? and ] assoc-subset ;
|
||||
!
|
||||
! : kill-node* ( node values -- )
|
||||
! [ swap remove-all ] curry modify-values ;
|
||||
!
|
||||
! : kill-node ( node values -- )
|
||||
! dup assoc-empty?
|
||||
! [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
|
||||
!
|
||||
! : kill-values ( node -- )
|
||||
! #! Remove literals which are not actually used anywhere.
|
||||
! dead-literals kill-node ;
|
||||
|
||||
: compute-dead-literals ( -- values )
|
||||
def-use get [ >r value? r> empty? and ] assoc-subset ;
|
||||
|
||||
|
|
@ -129,8 +115,18 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
|
|||
dead-literals [ kill-nodes ] with-variable
|
||||
] if ;
|
||||
|
||||
!
|
||||
|
||||
: sole-consumer ( #call -- node/f )
|
||||
node-out-d first used-by
|
||||
dup length 1 = [ first ] [ drop f ] if ;
|
||||
|
||||
: splice-def-use ( node -- )
|
||||
#! As a first approximation, we take all the values used
|
||||
#! by the set of new nodes, and push a 't' on their
|
||||
#! def-use list here. We could perform a full graph
|
||||
#! substitution, but we don't need to, because the next
|
||||
#! optimizer iteration will do that. We just need a minimal
|
||||
#! degree of accuracy; the new values should be marked as
|
||||
#! having _some_ usage, so that flushing doesn't erronously
|
||||
#! flush them away.
|
||||
[ compute-def-use def-use get keys ] with-scope
|
||||
def-use get [ [ t swap ?push ] change-at ] curry each ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,227 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic assocs inference inference.class
|
||||
inference.dataflow inference.backend inference.state io kernel
|
||||
math namespaces sequences vectors words quotations hashtables
|
||||
combinators classes generic.math continuations optimizer.def-use
|
||||
optimizer.backend generic.standard optimizer.specializers
|
||||
optimizer.def-use optimizer.pattern-match generic.standard
|
||||
optimizer.control ;
|
||||
IN: optimizer.inlining
|
||||
|
||||
GENERIC: remember-method* ( method-spec node -- )
|
||||
|
||||
M: #call remember-method*
|
||||
[ node-history ?push ] keep set-node-history ;
|
||||
|
||||
M: node remember-method*
|
||||
2drop ;
|
||||
|
||||
: remember-method ( method-spec node -- )
|
||||
swap dup second +inlined+ depends-on
|
||||
[ swap remember-method* ] curry each-node ;
|
||||
|
||||
: (splice-method) ( #call method-spec quot -- node )
|
||||
#! Must remember the method before splicing in, otherwise
|
||||
#! the rest of the IR will also remember the method
|
||||
pick node-in-d dataflow-with
|
||||
[ remember-method ] keep
|
||||
[ swap infer-classes/node ] 2keep
|
||||
[ splice-node ] keep ;
|
||||
|
||||
: splice-quot ( #call quot -- node )
|
||||
over node-in-d dataflow-with
|
||||
[ swap infer-classes/node ] 2keep
|
||||
[ splice-node ] keep ;
|
||||
|
||||
! #call
|
||||
: splice-method ( #call method-spec/t quot/t -- node/t )
|
||||
#! t indicates failure
|
||||
{
|
||||
{ [ dup t eq? ] [ 3drop t ] }
|
||||
{ [ 2over swap node-history member? ] [ 3drop t ] }
|
||||
{ [ t ] [ (splice-method) ] }
|
||||
} cond ;
|
||||
|
||||
! Single dispatch method inlining optimization
|
||||
: already-inlined? ( node -- ? )
|
||||
#! Was this node inlined from definition of 'word'?
|
||||
dup node-param swap node-history memq? ;
|
||||
|
||||
: specific-method ( class word -- class ) order min-class ;
|
||||
|
||||
: node-class# ( node n -- class )
|
||||
over node-in-d <reversed> ?nth node-class ;
|
||||
|
||||
: dispatching-class ( node word -- class )
|
||||
[ dispatch# node-class# ] keep specific-method ;
|
||||
|
||||
! A heuristic to avoid excessive inlining
|
||||
DEFER: (flat-length)
|
||||
|
||||
: word-flat-length ( word -- n )
|
||||
dup get over inline? not or
|
||||
[ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
|
||||
|
||||
: (flat-length) ( seq -- n )
|
||||
[
|
||||
{
|
||||
{ [ dup quotation? ] [ (flat-length) 1+ ] }
|
||||
{ [ dup array? ] [ (flat-length) ] }
|
||||
{ [ dup word? ] [ word-flat-length ] }
|
||||
{ [ t ] [ drop 1 ] }
|
||||
} cond
|
||||
] map sum ;
|
||||
|
||||
: flat-length ( seq -- n )
|
||||
[ word-def (flat-length) ] with-scope ;
|
||||
|
||||
: will-inline-method ( node word -- method-spec/t quot/t )
|
||||
#! t indicates failure
|
||||
tuck dispatching-class dup [
|
||||
swap [ 2array ] 2keep
|
||||
method method-word
|
||||
dup flat-length 10 >=
|
||||
[ 1quotation ] [ word-def ] if
|
||||
] [
|
||||
2drop t t
|
||||
] if ;
|
||||
|
||||
: inline-standard-method ( node word -- node )
|
||||
dupd will-inline-method splice-method ;
|
||||
|
||||
! Partial dispatch of math-generic words
|
||||
: math-both-known? ( word left right -- ? )
|
||||
math-class-max swap specific-method ;
|
||||
|
||||
: will-inline-math-method ( word left right -- method-spec/t quot/t )
|
||||
#! t indicates failure
|
||||
3dup math-both-known?
|
||||
[ [ 3array ] 3keep math-method ] [ 3drop t t ] if ;
|
||||
|
||||
: inline-math-method ( #call word -- node )
|
||||
over node-input-classes first2
|
||||
will-inline-math-method splice-method ;
|
||||
|
||||
: inline-method ( #call -- node )
|
||||
dup node-param {
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
{ [ t ] [ 2drop t ] }
|
||||
} cond ;
|
||||
|
||||
! Resolve type checks at compile time where possible
|
||||
: comparable? ( actual testing -- ? )
|
||||
#! If actual is a subset of testing or if the two classes
|
||||
#! are disjoint, return t.
|
||||
2dup class< >r classes-intersect? not r> or ;
|
||||
|
||||
: optimize-predicate? ( #call -- ? )
|
||||
dup node-param "predicating" word-prop dup [
|
||||
>r node-class-first r> comparable?
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: literal-quot ( node literals -- quot )
|
||||
#! Outputs a quotation which drops the node's inputs, and
|
||||
#! pushes some literals.
|
||||
>r node-in-d length \ drop <repetition>
|
||||
r> [ literalize ] map append >quotation ;
|
||||
|
||||
: inline-literals ( node literals -- node )
|
||||
#! Make #shuffle -> #push -> #return -> successor
|
||||
dupd literal-quot splice-quot ;
|
||||
|
||||
: evaluate-predicate ( #call -- ? )
|
||||
dup node-param "predicating" word-prop >r
|
||||
node-class-first r> class< ;
|
||||
|
||||
: optimize-predicate ( #call -- node )
|
||||
#! If the predicate is followed by a branch we fold it
|
||||
#! immediately
|
||||
dup evaluate-predicate swap
|
||||
dup node-successor #if? [
|
||||
dup drop-inputs >r
|
||||
node-successor swap 0 1 ? fold-branch
|
||||
r> [ set-node-successor ] keep
|
||||
] [
|
||||
swap 1array inline-literals
|
||||
] if ;
|
||||
|
||||
: optimizer-hooks ( node -- conditions )
|
||||
node-param "optimizer-hooks" word-prop ;
|
||||
|
||||
: optimizer-hook ( node -- pair/f )
|
||||
dup optimizer-hooks [ first call ] find 2nip ;
|
||||
|
||||
: optimize-hook ( node -- )
|
||||
dup optimizer-hook second call ;
|
||||
|
||||
: define-optimizers ( word optimizers -- )
|
||||
"optimizer-hooks" set-word-prop ;
|
||||
|
||||
: flush-eval? ( #call -- ? )
|
||||
dup node-param "flushable" word-prop [
|
||||
node-out-d [ unused? ] all?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: flush-eval ( #call -- node )
|
||||
dup node-param +inlined+ depends-on
|
||||
dup node-out-d length f <repetition> inline-literals ;
|
||||
|
||||
: partial-eval? ( #call -- ? )
|
||||
dup node-param "foldable" word-prop [
|
||||
dup node-in-d [ node-literal? ] with all?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: literal-in-d ( #call -- inputs )
|
||||
dup node-in-d [ node-literal ] with map ;
|
||||
|
||||
: partial-eval ( #call -- node )
|
||||
dup node-param +inlined+ depends-on
|
||||
dup literal-in-d over node-param 1quotation
|
||||
[ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
|
||||
|
||||
: define-identities ( words identities -- )
|
||||
[ "identities" set-word-prop ] curry each ;
|
||||
|
||||
: find-identity ( node -- quot )
|
||||
[ node-param "identities" word-prop ] keep
|
||||
[ swap first in-d-match? ] curry find
|
||||
nip dup [ second ] when ;
|
||||
|
||||
: apply-identities ( node -- node/f )
|
||||
dup find-identity dup [ splice-quot ] [ 2drop f ] if ;
|
||||
|
||||
: optimistic-inline? ( #call -- ? )
|
||||
dup node-param "specializer" word-prop dup [
|
||||
>r node-input-classes r> specialized-length tail*
|
||||
[ types length 1 = ] all?
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: optimistic-inline ( #call -- node )
|
||||
dup node-param dup +inlined+ depends-on
|
||||
word-def splice-quot ;
|
||||
|
||||
: method-body-inline? ( #call -- ? )
|
||||
node-param dup method-body?
|
||||
[ flat-length 8 <= ] [ drop f ] if ;
|
||||
|
||||
M: #call optimize-node*
|
||||
{
|
||||
{ [ dup flush-eval? ] [ flush-eval ] }
|
||||
{ [ dup partial-eval? ] [ partial-eval ] }
|
||||
{ [ dup find-identity ] [ apply-identities ] }
|
||||
{ [ dup optimizer-hook ] [ optimize-hook ] }
|
||||
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
|
||||
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
|
||||
{ [ dup method-body-inline? ] [ optimistic-inline ] }
|
||||
{ [ t ] [ inline-method ] }
|
||||
} cond dup not ;
|
||||
|
|
@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32
|
|||
io.streams.string layouts splitting math.intervals
|
||||
math.floats.private tuples tuples.private classes
|
||||
optimizer.def-use optimizer.backend optimizer.pattern-match
|
||||
float-arrays sequences.private combinators ;
|
||||
optimizer.inlining float-arrays sequences.private combinators ;
|
||||
|
||||
! the output of <tuple> and <tuple-boa> has the class which is
|
||||
! its second-to-last input
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ inference.class inference.dataflow vectors strings sbufs io
|
|||
namespaces assocs quotations math.intervals sequences.private
|
||||
combinators splitting layouts math.parser classes generic.math
|
||||
optimizer.pattern-match optimizer.backend optimizer.def-use
|
||||
generic.standard system ;
|
||||
optimizer.inlining generic.standard system ;
|
||||
|
||||
{ + bignum+ float+ fixnum+fast } {
|
||||
{ { number 0 } [ drop ] }
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel
|
|||
kernel.private math optimizer prettyprint sequences sbufs
|
||||
strings tools.test vectors words sequences.private quotations
|
||||
optimizer.backend classes inference.dataflow tuples.private
|
||||
continuations growable ;
|
||||
continuations growable optimizer.inlining ;
|
||||
IN: temporary
|
||||
|
||||
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
|
||||
|
|
@ -301,3 +301,31 @@ TUPLE: silly-tuple a b ;
|
|||
[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
|
||||
[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
|
||||
[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
|
||||
|
||||
! Regression
|
||||
: lift-throw-tail-regression
|
||||
dup integer? [ "an integer" ] [
|
||||
dup string? [ "a string" ] [
|
||||
"error" throw
|
||||
] if
|
||||
] if ;
|
||||
|
||||
[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test
|
||||
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
|
||||
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
|
||||
|
||||
: lift-loop-tail-test-1 ( a quot -- )
|
||||
over even? [
|
||||
[ >r 3 - r> call ] keep lift-loop-tail-test-1
|
||||
] [
|
||||
over 0 < [
|
||||
2drop
|
||||
] [
|
||||
[ >r 2 - r> call ] keep lift-loop-tail-test-1
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
: lift-loop-tail-test-2
|
||||
10 [ ] lift-loop-tail-test-1 1 2 3 ;
|
||||
|
||||
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces optimizer.backend optimizer.def-use
|
||||
optimizer.known-words optimizer.math optimizer.control
|
||||
inference.class ;
|
||||
optimizer.inlining inference.class ;
|
||||
IN: optimizer
|
||||
|
||||
: optimize-1 ( node -- newnode ? )
|
||||
|
|
@ -12,7 +12,7 @@ IN: optimizer
|
|||
H{ } clone value-substitutions set
|
||||
dup compute-def-use
|
||||
kill-values
|
||||
! dup detect-loops
|
||||
dup detect-loops
|
||||
dup infer-classes
|
||||
optimizer-changed off
|
||||
optimize-nodes
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ IN: optimizer.specializers
|
|||
\ dispatch ,
|
||||
] [ ] make ;
|
||||
|
||||
: specializer-methods ( word -- alist )
|
||||
: specializer-methods ( quot word -- default alist )
|
||||
dup [ array? ] all? [ 1array ] unless [
|
||||
[ make-specializer ] keep
|
||||
[ declare ] curry pick append
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ IN: benchmark
|
|||
: run-benchmark ( vocab -- result )
|
||||
"=== Benchmark " write dup print flush
|
||||
dup require
|
||||
[ [ run ] benchmark ] [ error. f f ] recover 2array
|
||||
[ [ run ] benchmark ] [ error. drop f f ] recover 2array
|
||||
dup . ;
|
||||
|
||||
: run-benchmarks ( -- assoc )
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ IN: benchmark.sockets
|
|||
CHAR: x write1
|
||||
] with-stream ;
|
||||
|
||||
: socket-benchmark ( n -- )
|
||||
: clients ( n -- )
|
||||
dup pprint " clients: " write
|
||||
[
|
||||
[ simple-server ] in-thread
|
||||
|
|
@ -33,11 +33,12 @@ IN: benchmark.sockets
|
|||
] time ;
|
||||
|
||||
: socket-benchmarks
|
||||
10 socket-benchmark
|
||||
20 socket-benchmark
|
||||
40 socket-benchmark
|
||||
80 socket-benchmark
|
||||
160 socket-benchmark
|
||||
320 socket-benchmark ;
|
||||
10 clients
|
||||
20 clients
|
||||
40 clients
|
||||
80 clients
|
||||
160 clients
|
||||
320 clients
|
||||
640 clients ;
|
||||
|
||||
MAIN: socket-benchmarks
|
||||
|
|
|
|||
|
|
@ -3,68 +3,18 @@ USING: kernel parser io io.files io.launcher io.sockets hashtables math threads
|
|||
arrays system continuations namespaces sequences splitting math.parser
|
||||
prettyprint tools.time calendar bake vars http.client
|
||||
combinators bootstrap.image bootstrap.image.download
|
||||
combinators.cleave benchmark ;
|
||||
combinators.cleave benchmark
|
||||
classes strings quotations words parser-combinators new-slots accessors
|
||||
assocs.lib smtp builder.util ;
|
||||
|
||||
IN: builder
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: runtime ( quot -- time ) benchmark nip ;
|
||||
|
||||
: minutes>ms ( min -- ms ) 60 * 1000 * ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: builder-recipients
|
||||
|
||||
: host-name* ( -- name ) host-name "." split first ;
|
||||
|
||||
: tag-subject ( str -- str ) `{ "builder@" ,[ host-name* ] ": " , } concat ;
|
||||
|
||||
: email-string ( subject -- )
|
||||
`{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] }
|
||||
[ ] with-process-stream drop ;
|
||||
|
||||
: email-file ( subject file -- )
|
||||
`{
|
||||
{ +stdin+ , }
|
||||
{ +arguments+
|
||||
{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] } }
|
||||
}
|
||||
>hashtable run-process drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ;
|
||||
|
||||
: factor-binary ( -- name )
|
||||
os
|
||||
{ { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
|
||||
{ "winnt" [ "./factor-nt.exe" ] }
|
||||
[ drop "./factor" ] }
|
||||
case ;
|
||||
|
||||
: git-pull ( -- desc )
|
||||
{
|
||||
"git"
|
||||
"pull"
|
||||
"--no-summary"
|
||||
"git://factorcode.org/git/factor.git"
|
||||
"master"
|
||||
} ;
|
||||
|
||||
: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: datestamp ( -- string )
|
||||
now `{ ,[ dup timestamp-year ]
|
||||
,[ dup timestamp-month ]
|
||||
,[ dup timestamp-day ]
|
||||
,[ dup timestamp-hour ]
|
||||
,[ timestamp-minute ] }
|
||||
[ pad-00 ] map "-" join ;
|
||||
|
||||
VAR: stamp
|
||||
|
||||
: enter-build-dir ( -- )
|
||||
|
|
@ -82,47 +32,41 @@ VAR: stamp
|
|||
|
||||
: make-clean ( -- desc ) { "make" "clean" } ;
|
||||
|
||||
: make-vm ( -- )
|
||||
`{
|
||||
{ +arguments+ { "make" ,[ target ] } }
|
||||
{ +stdout+ "../compile-log" }
|
||||
{ +stderr+ +stdout+ }
|
||||
}
|
||||
>hashtable ;
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ;
|
||||
|
||||
: make-vm ( -- desc )
|
||||
<process*>
|
||||
{ "make" target } to-strings >>arguments
|
||||
"../compile-log" >>stdout
|
||||
+stdout+ >>stderr
|
||||
>desc ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: factor-binary ( -- name )
|
||||
os
|
||||
{ { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
|
||||
{ "winnt" [ "./factor-nt.exe" ] }
|
||||
[ drop "./factor" ] }
|
||||
case ;
|
||||
|
||||
: bootstrap-cmd ( -- cmd )
|
||||
{ factor-binary [ "-i=" my-boot-image-name append ] "-no-user-init" }
|
||||
to-strings ;
|
||||
|
||||
: bootstrap ( -- desc )
|
||||
`{
|
||||
{ +arguments+ {
|
||||
,[ factor-binary ]
|
||||
,[ "-i=" my-boot-image-name append ]
|
||||
"-no-user-init"
|
||||
} }
|
||||
{ +stdout+ "../boot-log" }
|
||||
{ +stderr+ +stdout+ }
|
||||
{ +timeout+ ,[ 20 minutes>ms ] }
|
||||
} ;
|
||||
<process*>
|
||||
bootstrap-cmd >>arguments
|
||||
+closed+ >>stdin
|
||||
"../boot-log" >>stdout
|
||||
+stdout+ >>stderr
|
||||
20 minutes>ms >>timeout
|
||||
>desc ;
|
||||
|
||||
: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ;
|
||||
: builder-test ( -- desc ) { factor-binary "-run=builder.test" } to-strings ;
|
||||
|
||||
SYMBOL: build-status
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: milli-seconds>time ( n -- string )
|
||||
1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
|
||||
|
||||
: eval-file ( file -- obj ) <file-reader> contents eval ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: cat ( file -- ) <file-reader> contents print ;
|
||||
|
||||
: run-or-bail ( desc quot -- )
|
||||
[ [ try-process ] curry ]
|
||||
[ [ throw ] curry ]
|
||||
bi*
|
||||
recover ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (build) ( -- )
|
||||
|
|
@ -146,24 +90,8 @@ SYMBOL: build-status
|
|||
|
||||
[ my-arch download-image ] [ "Image download error" print throw ] recover
|
||||
|
||||
! bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
|
||||
bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
|
||||
|
||||
! bootstrap
|
||||
! <process-stream> dup dispose process-stream-process wait-for-process
|
||||
! zero? not
|
||||
! [ "Bootstrap error" print "../boot-log" cat "bootstrap error" throw ]
|
||||
! when
|
||||
|
||||
[
|
||||
bootstrap
|
||||
<process-stream> dup dispose process-stream-process wait-for-process
|
||||
zero? not
|
||||
[ "bootstrap non-zero" throw ]
|
||||
when
|
||||
]
|
||||
[ "Bootstrap error" print "../boot-log" cat "bootstrap" throw ]
|
||||
recover
|
||||
|
||||
[ builder-test try-process ]
|
||||
[ "Builder test error" print throw ]
|
||||
recover
|
||||
|
|
@ -180,12 +108,32 @@ SYMBOL: build-status
|
|||
|
||||
] with-file-out ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: builder-recipients
|
||||
|
||||
: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ;
|
||||
|
||||
: build ( -- )
|
||||
[ (build) ] [ drop ] recover
|
||||
"report" "../report" email-file ;
|
||||
<email>
|
||||
"ed@factorcode.org" >>from
|
||||
builder-recipients get >>to
|
||||
"report" tag-subject >>subject
|
||||
"../report" file>string >>body
|
||||
send ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: git-pull ( -- desc )
|
||||
{
|
||||
"git"
|
||||
"pull"
|
||||
"--no-summary"
|
||||
"git://factorcode.org/git/factor.git"
|
||||
"master"
|
||||
} ;
|
||||
|
||||
: updates-available? ( -- ? )
|
||||
git-id
|
||||
git-pull run-process drop
|
||||
|
|
|
|||
|
|
@ -41,28 +41,28 @@ IN: builder.server
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: build-server ( -- )
|
||||
receive
|
||||
{
|
||||
{
|
||||
"start"
|
||||
[
|
||||
build-status get "idle" =
|
||||
build-status get f =
|
||||
or
|
||||
[
|
||||
[ [ build ] [ drop ] recover "idle" build-status set-global ]
|
||||
in-thread
|
||||
]
|
||||
when
|
||||
]
|
||||
}
|
||||
! : build-server ( -- )
|
||||
! receive
|
||||
! {
|
||||
! {
|
||||
! "start"
|
||||
! [
|
||||
! build-status get "idle" =
|
||||
! build-status get f =
|
||||
! or
|
||||
! [
|
||||
! [ [ build ] [ drop ] recover "idle" build-status set-global ]
|
||||
! in-thread
|
||||
! ]
|
||||
! when
|
||||
! ]
|
||||
! }
|
||||
|
||||
{
|
||||
{ ?from ?tag "status" }
|
||||
[ `{ ?tag ,[ build-status get ] } ?from send ]
|
||||
}
|
||||
}
|
||||
match-cond
|
||||
build-server ;
|
||||
! {
|
||||
! { ?from ?tag "status" }
|
||||
! [ `{ ?tag ,[ build-status get ] } ?from send ]
|
||||
! }
|
||||
! }
|
||||
! match-cond
|
||||
! build-server ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ USING: kernel namespaces sequences assocs builder continuations
|
|||
prettyprint
|
||||
tools.browser
|
||||
tools.test
|
||||
bootstrap.stage2 benchmark ;
|
||||
bootstrap.stage2 benchmark builder.util ;
|
||||
|
||||
IN: builder.test
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,83 @@
|
|||
|
||||
USING: kernel words namespaces classes parser continuations
|
||||
io io.files io.launcher io.sockets
|
||||
math math.parser
|
||||
combinators sequences splitting quotations arrays strings tools.time
|
||||
parser-combinators accessors assocs.lib
|
||||
combinators.cleave bake calendar new-slots ;
|
||||
|
||||
IN: builder.util
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: runtime ( quot -- time ) benchmark nip ;
|
||||
|
||||
: minutes>ms ( min -- ms ) 60 * 1000 * ;
|
||||
|
||||
: file>string ( file -- string ) [ stdio get contents ] with-file-in ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
DEFER: to-strings
|
||||
|
||||
: to-string ( obj -- str )
|
||||
dup class
|
||||
{
|
||||
{ string [ ] }
|
||||
{ quotation [ call ] }
|
||||
{ word [ execute ] }
|
||||
{ fixnum [ number>string ] }
|
||||
{ array [ to-strings concat ] }
|
||||
}
|
||||
case ;
|
||||
|
||||
: to-strings ( seq -- str )
|
||||
dup [ string? ] all?
|
||||
[ ]
|
||||
[ [ to-string ] map flatten ]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: process* arguments stdin stdout stderr timeout ;
|
||||
|
||||
: <process*> process* construct-empty ;
|
||||
|
||||
: >desc ( process* -- desc )
|
||||
H{ } clone
|
||||
over arguments>> [ +arguments+ swap put-at ] when*
|
||||
over stdin>> [ +stdin+ swap put-at ] when*
|
||||
over stdout>> [ +stdout+ swap put-at ] when*
|
||||
over stderr>> [ +stderr+ swap put-at ] when*
|
||||
over timeout>> [ +timeout+ swap put-at ] when*
|
||||
nip ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: host-name* ( -- name ) host-name "." split first ;
|
||||
|
||||
: datestamp ( -- string )
|
||||
now `{ ,[ dup timestamp-year ]
|
||||
,[ dup timestamp-month ]
|
||||
,[ dup timestamp-day ]
|
||||
,[ dup timestamp-hour ]
|
||||
,[ timestamp-minute ] }
|
||||
[ pad-00 ] map "-" join ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: milli-seconds>time ( n -- string )
|
||||
1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
|
||||
|
||||
: eval-file ( file -- obj ) <file-reader> contents eval ;
|
||||
|
||||
: cat ( file -- ) <file-reader> contents print ;
|
||||
|
||||
: run-or-bail ( desc quot -- )
|
||||
[ [ try-process ] curry ]
|
||||
[ [ throw ] compose ]
|
||||
bi*
|
||||
recover ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
USING: kernel parser words sequences ;
|
||||
IN: const
|
||||
|
||||
: define-const ( word value -- )
|
||||
[ parsed ] curry dupd define
|
||||
t "parsing" set-word-prop ;
|
||||
|
||||
: CONST:
|
||||
CREATE scan-word dup parsing?
|
||||
[ execute dup pop ] when define-const ; parsing
|
||||
|
||||
: define-enum ( words -- )
|
||||
dup length [ define-const ] 2each ;
|
||||
|
||||
: ENUM:
|
||||
";" parse-tokens [ create-in ] map define-enum ; parsing
|
||||
|
||||
: define-value ( word -- )
|
||||
{ f } clone [ first ] curry define ;
|
||||
|
||||
: VALUE: CREATE define-value ; parsing
|
||||
|
||||
: set-value ( value word -- )
|
||||
word-def first set-first ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: delegate sequences.private sequences assocs prettyprint.sections
|
||||
io definitions kernel ;
|
||||
io definitions kernel continuations ;
|
||||
IN: delegate.protocols
|
||||
|
||||
PROTOCOL: sequence-protocol
|
||||
|
|
@ -15,7 +15,7 @@ PROTOCOL: assoc-protocol
|
|||
! everything should work, just slower (with >alist)
|
||||
|
||||
PROTOCOL: stream-protocol
|
||||
stream-read1 stream-read stream-read-until
|
||||
stream-read1 stream-read stream-read-until dispose
|
||||
stream-flush stream-write1 stream-write stream-format
|
||||
stream-nl make-span-stream make-block-stream stream-readln
|
||||
make-cell-stream stream-write-table ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2003, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: hashtables io kernel math namespaces math.parser assocs
|
||||
sequences strings splitting ascii io.utf8 assocs.lib
|
||||
sequences strings splitting ascii io.encodings.utf8 assocs.lib
|
||||
namespaces unicode.case ;
|
||||
IN: http
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2007 Gavin Harrison
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math sequences kernel.private namespaces arrays io io.files
|
||||
splitting io.binary math.functions vectors quotations sequences.private ;
|
||||
USING: kernel math sequences kernel.private namespaces arrays io
|
||||
io.files splitting io.binary math.functions vectors quotations
|
||||
combinators ;
|
||||
IN: icfp.2006
|
||||
|
||||
SYMBOL: regs
|
||||
|
|
@ -9,10 +10,6 @@ SYMBOL: arrays
|
|||
SYMBOL: finger
|
||||
SYMBOL: open-arrays
|
||||
|
||||
: call-nth ( n array -- )
|
||||
>r >fixnum r> 2dup nth quotation?
|
||||
[ dispatch ] [ "Not a quotation" throw ] if ; inline
|
||||
|
||||
: reg-val ( m -- n ) regs get nth ;
|
||||
|
||||
: set-reg ( val n -- ) regs get set-nth ;
|
||||
|
|
@ -117,11 +114,21 @@ SYMBOL: open-arrays
|
|||
: run-op ( -- bool )
|
||||
advance
|
||||
{
|
||||
[ op0 ] [ op1 ] [ op2 ] [ op3 ]
|
||||
[ op4 ] [ op5 ] [ op6 ] [ drop t ]
|
||||
[ op8 ] [ op9 ] [ op10 ] [ op11 ]
|
||||
[ op12 ] [ op13 ]
|
||||
} call-nth ;
|
||||
{ 0 [ op0 ] }
|
||||
{ 1 [ op1 ] }
|
||||
{ 2 [ op2 ] }
|
||||
{ 3 [ op3 ] }
|
||||
{ 4 [ op4 ] }
|
||||
{ 5 [ op5 ] }
|
||||
{ 6 [ op6 ] }
|
||||
{ 7 [ drop t ] }
|
||||
{ 8 [ op8 ] }
|
||||
{ 9 [ op9 ] }
|
||||
{ 10 [ op10 ] }
|
||||
{ 11 [ op11 ] }
|
||||
{ 12 [ op12 ] }
|
||||
{ 13 [ op13 ] }
|
||||
} case ;
|
||||
|
||||
: exec-loop ( bool -- )
|
||||
[ run-op exec-loop ] unless ;
|
||||
|
|
|
|||
|
|
@ -119,7 +119,9 @@ HOOK: process-stream* io-backend ( desc -- stream process )
|
|||
TUPLE: process-stream process ;
|
||||
|
||||
: <process-stream> ( desc -- stream )
|
||||
>descriptor process-stream*
|
||||
>descriptor
|
||||
[ process-stream* ] keep
|
||||
+timeout+ swap at [ over set-timeout ] when*
|
||||
{ set-delegate set-process-stream-process }
|
||||
process-stream construct ;
|
||||
|
||||
|
|
|
|||
|
|
@ -50,15 +50,16 @@ MEMO: 'arguments' ( -- parser )
|
|||
: redirect ( obj mode fd -- )
|
||||
{
|
||||
{ [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] }
|
||||
{ [ pick +closed+ eq? ] [ close 2drop ] }
|
||||
{ [ pick string? ] [ (redirect) ] }
|
||||
} cond ;
|
||||
|
||||
: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
|
||||
|
||||
: setup-redirection ( -- )
|
||||
+stdin+ get read-flags 0 redirect
|
||||
+stdout+ get write-flags 1 redirect
|
||||
+stdin+ get ?closed read-flags 0 redirect
|
||||
+stdout+ get ?closed write-flags 1 redirect
|
||||
+stderr+ get dup +stdout+ eq?
|
||||
[ drop 1 2 dup2 io-error ] [ write-flags 2 redirect ] if ;
|
||||
[ drop 1 2 dup2 io-error ] [ ?closed write-flags 2 redirect ] if ;
|
||||
|
||||
: spawn-process ( -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays continuations destructors io
|
||||
io.windows io.windows.pipes libc io.nonblocking
|
||||
io.windows io.windows.nt.pipes libc io.nonblocking
|
||||
io.streams.duplex windows.types math windows.kernel32 windows
|
||||
namespaces io.launcher kernel sequences windows.errors assocs
|
||||
splitting system threads init strings combinators io.backend ;
|
||||
|
|
@ -87,75 +87,26 @@ TUPLE: CreateProcess-args
|
|||
over set-CreateProcess-args-lpEnvironment
|
||||
] when ;
|
||||
|
||||
: (redirect) ( path access-mode create-mode -- handle )
|
||||
>r >r
|
||||
normalize-pathname
|
||||
r> ! access-mode
|
||||
share-mode
|
||||
security-attributes-inherit
|
||||
r> ! create-mode
|
||||
FILE_ATTRIBUTE_NORMAL ! flags and attributes
|
||||
f ! template file
|
||||
CreateFile dup invalid-handle? dup close-later ;
|
||||
|
||||
: redirect ( obj access-mode create-mode -- handle )
|
||||
{
|
||||
{ [ pick not ] [ 3drop f ] }
|
||||
{ [ pick +closed+ eq? ] [ 3drop t ] }
|
||||
{ [ pick string? ] [ (redirect) ] }
|
||||
} cond ;
|
||||
|
||||
: ?closed or dup t eq? [ drop f ] when ;
|
||||
|
||||
: inherited-stdout ( args -- handle )
|
||||
CreateProcess-args-stdout-pipe
|
||||
[ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
|
||||
|
||||
: redirect-stdout ( args -- handle )
|
||||
+stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
|
||||
swap inherited-stdout ?closed ;
|
||||
|
||||
: inherited-stderr ( args -- handle )
|
||||
drop STD_ERROR_HANDLE GetStdHandle ;
|
||||
|
||||
: redirect-stderr ( args -- handle )
|
||||
+stderr+ get
|
||||
dup +stdout+ eq? [
|
||||
drop
|
||||
CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
|
||||
] [
|
||||
GENERIC_WRITE CREATE_ALWAYS redirect
|
||||
swap inherited-stderr ?closed
|
||||
] if ;
|
||||
|
||||
: inherited-stdin ( args -- handle )
|
||||
CreateProcess-args-stdin-pipe
|
||||
[ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
|
||||
|
||||
: redirect-stdin ( args -- handle )
|
||||
+stdin+ get GENERIC_READ OPEN_EXISTING redirect
|
||||
swap inherited-stdin ?closed ;
|
||||
|
||||
: fill-startup-info
|
||||
dup CreateProcess-args-lpStartupInfo
|
||||
STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
|
||||
STARTF_USESTDHANDLES swap set-STARTUPINFO-dwFlags ;
|
||||
|
||||
over redirect-stdout over set-STARTUPINFO-hStdOutput
|
||||
over redirect-stderr over set-STARTUPINFO-hStdError
|
||||
over redirect-stdin over set-STARTUPINFO-hStdInput
|
||||
HOOK: fill-redirection io-backend ( args -- args )
|
||||
|
||||
drop ;
|
||||
M: windows-ce-io fill-redirection ;
|
||||
|
||||
: make-CreateProcess-args ( -- args )
|
||||
default-CreateProcess-args
|
||||
wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
|
||||
fill-dwCreateFlags
|
||||
fill-lpEnvironment ;
|
||||
fill-lpEnvironment
|
||||
fill-startup-info ;
|
||||
|
||||
M: windows-io run-process* ( desc -- handle )
|
||||
[
|
||||
[
|
||||
make-CreateProcess-args fill-startup-info
|
||||
make-CreateProcess-args
|
||||
fill-redirection
|
||||
dup call-CreateProcess
|
||||
CreateProcess-args-lpProcessInformation <process>
|
||||
] with-descriptor
|
||||
|
|
|
|||
|
|
@ -3,13 +3,63 @@
|
|||
USING: alien alien.c-types arrays continuations destructors io
|
||||
io.windows libc io.nonblocking io.streams.duplex windows.types
|
||||
math windows.kernel32 windows namespaces io.launcher kernel
|
||||
sequences windows.errors assocs splitting system
|
||||
io.windows.launcher io.windows.pipes ;
|
||||
sequences windows.errors assocs splitting system strings
|
||||
io.windows.launcher io.windows.nt.pipes io.backend
|
||||
combinators ;
|
||||
IN: io.windows.nt.launcher
|
||||
|
||||
! The below code is based on the example given in
|
||||
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
|
||||
|
||||
: (redirect) ( path access-mode create-mode -- handle )
|
||||
>r >r
|
||||
normalize-pathname
|
||||
r> ! access-mode
|
||||
share-mode
|
||||
security-attributes-inherit
|
||||
r> ! create-mode
|
||||
FILE_ATTRIBUTE_NORMAL ! flags and attributes
|
||||
f ! template file
|
||||
CreateFile dup invalid-handle? dup close-later ;
|
||||
|
||||
: redirect ( obj access-mode create-mode -- handle )
|
||||
{
|
||||
{ [ pick not ] [ 3drop f ] }
|
||||
{ [ pick +closed+ eq? ] [ drop nip null-pipe ] }
|
||||
{ [ pick string? ] [ (redirect) ] }
|
||||
} cond ;
|
||||
|
||||
: ?closed or dup t eq? [ drop f ] when ;
|
||||
|
||||
: inherited-stdout ( args -- handle )
|
||||
CreateProcess-args-stdout-pipe
|
||||
[ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
|
||||
|
||||
: redirect-stdout ( args -- handle )
|
||||
+stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
|
||||
swap inherited-stdout ?closed ;
|
||||
|
||||
: inherited-stderr ( args -- handle )
|
||||
drop STD_ERROR_HANDLE GetStdHandle ;
|
||||
|
||||
: redirect-stderr ( args -- handle )
|
||||
+stderr+ get
|
||||
dup +stdout+ eq? [
|
||||
drop
|
||||
CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
|
||||
] [
|
||||
GENERIC_WRITE CREATE_ALWAYS redirect
|
||||
swap inherited-stderr ?closed
|
||||
] if ;
|
||||
|
||||
: inherited-stdin ( args -- handle )
|
||||
CreateProcess-args-stdin-pipe
|
||||
[ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
|
||||
|
||||
: redirect-stdin ( args -- handle )
|
||||
+stdin+ get GENERIC_READ OPEN_EXISTING redirect
|
||||
swap inherited-stdin ?closed ;
|
||||
|
||||
: set-inherit ( handle ? -- )
|
||||
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
|
||||
|
||||
|
|
@ -30,14 +80,22 @@ IN: io.windows.nt.launcher
|
|||
dup pipe-out f set-inherit
|
||||
over set-CreateProcess-args-stdin-pipe ;
|
||||
|
||||
M: windows-io process-stream*
|
||||
M: windows-nt-io fill-redirection
|
||||
dup CreateProcess-args-lpStartupInfo
|
||||
over redirect-stdout over set-STARTUPINFO-hStdOutput
|
||||
over redirect-stderr over set-STARTUPINFO-hStdError
|
||||
over redirect-stdin over set-STARTUPINFO-hStdInput
|
||||
drop ;
|
||||
|
||||
M: windows-nt-io process-stream*
|
||||
[
|
||||
[
|
||||
make-CreateProcess-args
|
||||
|
||||
fill-stdout-pipe
|
||||
fill-stdin-pipe
|
||||
fill-startup-info
|
||||
|
||||
fill-redirection
|
||||
|
||||
dup call-CreateProcess
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays destructors io io.windows libc
|
||||
windows.types math windows.kernel32 windows namespaces kernel
|
||||
sequences windows.errors assocs math.parser system random ;
|
||||
IN: io.windows.pipes
|
||||
sequences windows.errors assocs math.parser system random
|
||||
combinators ;
|
||||
IN: io.windows.nt.pipes
|
||||
|
||||
! This code is based on
|
||||
! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
|
||||
|
|
@ -65,3 +66,20 @@ TUPLE: pipe in out ;
|
|||
|
||||
: <unique-outgoing-pipe> ( -- pipe )
|
||||
unique-pipe-name <outgoing-pipe> ;
|
||||
|
||||
! /dev/null simulation
|
||||
: null-input ( -- pipe )
|
||||
<unique-outgoing-pipe>
|
||||
dup pipe-out CloseHandle drop
|
||||
pipe-in ;
|
||||
|
||||
: null-output ( -- pipe )
|
||||
<unique-incoming-pipe>
|
||||
dup pipe-in CloseHandle drop
|
||||
pipe-out ;
|
||||
|
||||
: null-pipe ( mode -- pipe )
|
||||
{
|
||||
{ [ dup GENERIC_READ = ] [ drop null-input ] }
|
||||
{ [ dup GENERIC_WRITE = ] [ drop null-output ] }
|
||||
} cond ;
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
USING: kernel math math.constants math.functions math.intervals
|
||||
math.vectors namespaces sequences ;
|
||||
math.vectors namespaces sequences combinators.cleave ;
|
||||
IN: math.analysis
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -7,8 +7,11 @@ IN: multiline
|
|||
lexer get dup next-line lexer-line-text ;
|
||||
|
||||
: (parse-here) ( -- )
|
||||
next-line-text dup ";" =
|
||||
[ drop lexer get next-line ] [ % "\n" % (parse-here) ] if ;
|
||||
next-line-text [
|
||||
dup ";" =
|
||||
[ drop lexer get next-line ]
|
||||
[ % "\n" % (parse-here) ] if
|
||||
] [ ";" unexpected-eof ] if* ;
|
||||
|
||||
: parse-here ( -- str )
|
||||
[ (parse-here) ] "" make 1 head*
|
||||
|
|
@ -19,11 +22,13 @@ IN: multiline
|
|||
parse-here 1quotation define-inline ; parsing
|
||||
|
||||
: (parse-multiline-string) ( start-index end-text -- end-index )
|
||||
lexer get lexer-line-text 2dup start
|
||||
[ rot dupd >r >r swap subseq % r> r> length + ] [
|
||||
rot tail % "\n" % 0
|
||||
lexer get next-line swap (parse-multiline-string)
|
||||
] if* ;
|
||||
lexer get lexer-line-text [
|
||||
2dup start
|
||||
[ rot dupd >r >r swap subseq % r> r> length + ] [
|
||||
rot tail % "\n" % 0
|
||||
lexer get next-line swap (parse-multiline-string)
|
||||
] if*
|
||||
] [ nip unexpected-eof ] if* ;
|
||||
|
||||
: parse-multiline-string ( end-text -- str )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -95,14 +95,18 @@ M: #dispatch node>quot
|
|||
node-children swap [ dataflow>quot ] curry map ,
|
||||
\ dispatch , ;
|
||||
|
||||
M: #return node>quot
|
||||
dup node-param unparse "#return " swap append comment, ;
|
||||
|
||||
M: #>r node>quot nip node-in-d length \ >r <array> % ;
|
||||
|
||||
M: #r> node>quot nip node-out-d length \ r> <array> % ;
|
||||
|
||||
M: object node>quot dup class word-name comment, ;
|
||||
M: object node>quot
|
||||
[
|
||||
dup class word-name %
|
||||
" " %
|
||||
dup node-param unparse %
|
||||
" " %
|
||||
dup effect-str %
|
||||
] "" make comment, ;
|
||||
|
||||
: (dataflow>quot) ( ? node -- )
|
||||
dup [
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@
|
|||
|
||||
USING: combinators kernel prettyprint io io.timeouts io.server
|
||||
sequences namespaces io.sockets continuations ;
|
||||
IN: smtp.server
|
||||
|
||||
SYMBOL: data-mode
|
||||
|
||||
|
|
@ -55,7 +56,7 @@ SYMBOL: data-mode
|
|||
data-mode off
|
||||
"220 OK\r\n" write flush t
|
||||
] }
|
||||
{ [ data-mode get ] [ t ] }
|
||||
{ [ data-mode get ] [ global [ print ] bind t ] }
|
||||
{ [ t ] [
|
||||
"500 ERROR\r\n" write flush t
|
||||
] }
|
||||
|
|
@ -68,5 +69,6 @@ SYMBOL: data-mode
|
|||
60000 stdio get set-timeout
|
||||
"220 hello\r\n" write flush
|
||||
process
|
||||
global [ flush ] bind
|
||||
] with-stream
|
||||
] with-disposal ;
|
||||
|
|
|
|||
|
|
@ -139,7 +139,7 @@ LOG: smtp-response DEBUG
|
|||
: prepare-message ( body headers -- body' )
|
||||
[
|
||||
prepare-headers
|
||||
" " ,
|
||||
"" ,
|
||||
dup string? [ string-lines ] when %
|
||||
] { } make ;
|
||||
|
||||
|
|
@ -169,3 +169,15 @@ LOG: smtp-response DEBUG
|
|||
! : cram-md5-auth ( key login -- )
|
||||
! "AUTH CRAM-MD5\r\n" get-ok
|
||||
! (cram-md5-auth) "\r\n" append get-ok ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
USE: new-slots
|
||||
|
||||
TUPLE: email from to subject body ;
|
||||
|
||||
: <email> ( -- email ) email construct-empty ;
|
||||
|
||||
: send ( email -- )
|
||||
{ email-body email-subject email-to email-from } get-slots
|
||||
send-simple-message ;
|
||||
|
|
@ -132,7 +132,7 @@ MEMO: all-vocabs-seq ( -- seq )
|
|||
require-all ;
|
||||
|
||||
: load-everything ( -- )
|
||||
try-everything drop ;
|
||||
try-everything load-failures. ;
|
||||
|
||||
: unrooted-child-vocabs ( prefix -- seq )
|
||||
dup empty? [ CHAR: . add ] unless
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2005, 2007 Eduardo Cavazos and Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays ui ui.gadgets ui.gestures ui.backend
|
||||
ui.clipboards ui.gadgets.worlds assocs kernel math namespaces
|
||||
opengl sequences strings x11.xlib x11.events x11.xim x11.glx
|
||||
x11.clipboard x11.constants x11.windows io.utf8 combinators
|
||||
debugger system command-line ui.render math.vectors tuples
|
||||
opengl.gl threads ;
|
||||
USING: alien alien.c-types arrays ui ui.gadgets ui.gestures
|
||||
ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math
|
||||
namespaces opengl sequences strings x11.xlib x11.events x11.xim
|
||||
x11.glx x11.clipboard x11.constants x11.windows
|
||||
io.encodings.utf8 combinators debugger system command-line
|
||||
ui.render math.vectors tuples opengl.gl threads ;
|
||||
IN: ui.x11
|
||||
|
||||
TUPLE: x11-ui-backend ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: unicode.categories kernel math combinators splitting
|
||||
sequences math.parser io.files io assocs arrays namespaces
|
||||
combinators.lib assocs.lib math.ranges unicode.normalize
|
||||
unicode.syntax unicode.data compiler.units alien.syntax const ;
|
||||
unicode.syntax unicode.data compiler.units alien.syntax ;
|
||||
IN: unicode.breaks
|
||||
|
||||
C-ENUM: Any L V T Extend Control CR LF graphemes ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,16 @@
|
|||
USING: assocs math kernel sequences io.files hashtables
|
||||
quotations splitting arrays math.parser combinators.lib hash2
|
||||
byte-arrays words namespaces words compiler.units const ;
|
||||
byte-arrays words namespaces words compiler.units parser ;
|
||||
IN: unicode.data
|
||||
|
||||
<<
|
||||
: VALUE:
|
||||
CREATE dup reset-generic { f } clone [ first ] curry define ; parsing
|
||||
|
||||
: set-value ( value word -- )
|
||||
word-def first set-first ;
|
||||
>>
|
||||
|
||||
! Convenience functions
|
||||
: 1+* ( n/f _ -- n+1 )
|
||||
drop [ 1+ ] [ 0 ] if* ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.syntax arrays kernel math
|
||||
namespaces sequences io.utf8 x11.xlib x11.constants ;
|
||||
namespaces sequences io.encodings.utf8 x11.xlib x11.constants ;
|
||||
IN: x11.clipboard
|
||||
|
||||
! This code was based on by McCLIM's Backends/CLX/port.lisp
|
||||
|
|
|
|||
Loading…
Reference in New Issue