diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index ff9d5c5e1e..6d21504f8b 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -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 diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index d91c920def..5b87297b0c 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -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" } } diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor old mode 100644 new mode 100755 index 3cefda7f71..ce8e180867 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -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 diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 0ba8b583be..ffd1576e6e 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -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 ; diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor index 71c95b1b61..137d86b489 100755 --- a/core/compiler/tests/stack-trace.factor +++ b/core/compiler/tests/stack-trace.factor @@ -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 diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor index e518d2de8a..13d834a489 100755 --- a/core/compiler/tests/templates-early.factor +++ b/core/compiler/tests/templates-early.factor @@ -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 diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index b24928a71e..8c935db859 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -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 ; diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 58094f584f..9bca648b08 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -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? ; diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 7faeefc3d6..240f39218b 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -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 diff --git a/core/io/utf16/authors.txt b/core/io/encodings/binary/authors.txt similarity index 100% rename from core/io/utf16/authors.txt rename to core/io/encodings/binary/authors.txt diff --git a/core/io/encodings/binary/binary-docs.factor b/core/io/encodings/binary/binary-docs.factor new file mode 100644 index 0000000000..f8be5054df --- /dev/null +++ b/core/io/encodings/binary/binary-docs.factor @@ -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." } ; diff --git a/core/io/encodings/binary/binary.factor b/core/io/encodings/binary/binary.factor new file mode 100644 index 0000000000..b58f9836c0 --- /dev/null +++ b/core/io/encodings/binary/binary.factor @@ -0,0 +1,6 @@ +USING: kernel io.encodings ; + +TUPLE: binary ; + +M: binary init-decoding drop ; +M: binary init-encoding drop ; diff --git a/core/io/encodings/binary/summary.txt b/core/io/encodings/binary/summary.txt new file mode 100644 index 0000000000..a1eb4bc664 --- /dev/null +++ b/core/io/encodings/binary/summary.txt @@ -0,0 +1 @@ +Dummy encoding for binary I/O diff --git a/core/io/encodings/binary/tags.txt b/core/io/encodings/binary/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/core/io/encodings/binary/tags.txt @@ -0,0 +1 @@ +text diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 767e9b266b..27c74fc4bd 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -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 0 begin ] keep r> each +: start-decoding ( seq length -- buf ch state seq ) + 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 ) + +: ( stream decoding-class -- decoded-stream ) + construct-empty init-decoding ; + +GENERIC: init-encoding ( stream encoding -- encoded-stream ) + +: ( stream encoding-class -- encoded-stream ) + construct-empty init-encoding ; + +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 ; diff --git a/core/io/utf8/authors.txt b/core/io/encodings/latin1/authors.txt similarity index 100% rename from core/io/utf8/authors.txt rename to core/io/encodings/latin1/authors.txt diff --git a/core/io/encodings/latin1/latin1-docs.factor b/core/io/encodings/latin1/latin1-docs.factor new file mode 100644 index 0000000000..5872b2bcfd --- /dev/null +++ b/core/io/encodings/latin1/latin1-docs.factor @@ -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" } ; diff --git a/core/io/encodings/latin1/latin1.factor b/core/io/encodings/latin1/latin1.factor new file mode 100755 index 0000000000..468324316d --- /dev/null +++ b/core/io/encodings/latin1/latin1.factor @@ -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 ; diff --git a/core/io/encodings/latin1/summary.txt b/core/io/encodings/latin1/summary.txt new file mode 100644 index 0000000000..d40d628767 --- /dev/null +++ b/core/io/encodings/latin1/summary.txt @@ -0,0 +1 @@ +ISO 8859-1 encoding/decoding diff --git a/core/io/encodings/latin1/tags.txt b/core/io/encodings/latin1/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/core/io/encodings/latin1/tags.txt @@ -0,0 +1 @@ +text diff --git a/core/io/encodings/utf16/.utf16.factor.swo b/core/io/encodings/utf16/.utf16.factor.swo new file mode 100644 index 0000000000..01be8fdab2 Binary files /dev/null and b/core/io/encodings/utf16/.utf16.factor.swo differ diff --git a/core/io/encodings/utf16/authors.txt b/core/io/encodings/utf16/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/core/io/encodings/utf16/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/core/io/utf16/summary.txt b/core/io/encodings/utf16/summary.txt similarity index 100% rename from core/io/utf16/summary.txt rename to core/io/encodings/utf16/summary.txt diff --git a/core/io/encodings/utf16/tags.txt b/core/io/encodings/utf16/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/core/io/encodings/utf16/tags.txt @@ -0,0 +1 @@ +text diff --git a/core/io/utf16/utf16-docs.factor b/core/io/encodings/utf16/utf16-docs.factor similarity index 99% rename from core/io/utf16/utf16-docs.factor rename to core/io/encodings/utf16/utf16-docs.factor index 6d24f54694..c49c030ef3 100644 --- a/core/io/utf16/utf16-docs.factor +++ b/core/io/encodings/utf16/utf16-docs.factor @@ -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." diff --git a/core/io/utf16/utf16-tests.factor b/core/io/encodings/utf16/utf16-tests.factor similarity index 100% rename from core/io/utf16/utf16-tests.factor rename to core/io/encodings/utf16/utf16-tests.factor diff --git a/core/io/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor similarity index 79% rename from core/io/utf16/utf16.factor rename to core/io/encodings/utf16/utf16.factor index 19ebc1d43a..84017324ee 100755 --- a/core/io/utf16/utf16.factor +++ b/core/io/encodings/utf16/utf16.factor @@ -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 construct-delegate ; +INSTANCE: utf16le encoding-stream + +M: utf16le encode-string drop encode-utf16le ; +M: utf16le decode-step drop decode-utf16le-step ; + +TUPLE: utf16be ; +: utf16be construct-delegate ; +INSTANCE: utf16be encoding-stream + +M: utf16be encode-string drop encode-utf16be ; +M: utf16be decode-step drop decode-utf16be-step ; diff --git a/core/io/encodings/utf8/authors.txt b/core/io/encodings/utf8/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/core/io/encodings/utf8/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/core/io/utf8/summary.txt b/core/io/encodings/utf8/summary.txt similarity index 100% rename from core/io/utf8/summary.txt rename to core/io/encodings/utf8/summary.txt diff --git a/core/io/encodings/utf8/tags.txt b/core/io/encodings/utf8/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/core/io/encodings/utf8/tags.txt @@ -0,0 +1 @@ +text diff --git a/core/io/utf8/utf8-docs.factor b/core/io/encodings/utf8/utf8-docs.factor old mode 100644 new mode 100755 similarity index 86% rename from core/io/utf8/utf8-docs.factor rename to core/io/encodings/utf8/utf8-docs.factor index 28310b5d77..6e1923824f --- a/core/io/utf8/utf8-docs.factor +++ b/core/io/encodings/utf8/utf8-docs.factor @@ -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 } } diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor new file mode 100644 index 0000000000..33c4ffbf12 --- /dev/null +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -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 contents >array ; + +: encode-utf8-w/stream ( array -- newarray ) + SBUF" " clone tuck 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 diff --git a/core/io/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor similarity index 77% rename from core/io/utf8/utf8.factor rename to core/io/encodings/utf8/utf8.factor index 213afb6eae..f681b18142 100644 --- a/core/io/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -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 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 diff --git a/core/io/utf8/utf8-tests.factor b/core/io/utf8/utf8-tests.factor deleted file mode 100644 index 3576471586..0000000000 --- a/core/io/utf8/utf8-tests.factor +++ /dev/null @@ -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 diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 1ae3b4388c..3fe3a3e25f 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -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 ?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 - 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 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 ; diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor old mode 100644 new mode 100755 index 02df55216c..de3aeb220a --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -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 ; diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor index 9355b2bb70..df5c1e0aa4 100755 --- a/core/optimizer/def-use/def-use.factor +++ b/core/optimizer/def-use/def-use.factor @@ -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 ; diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor new file mode 100755 index 0000000000..a272d05b5d --- /dev/null +++ b/core/optimizer/inlining/inlining.factor @@ -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 ?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 + 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 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 ; diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 8534f1f090..d725396e77 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -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 and has the class which is ! its second-to-last input diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index e048e29f48..9bd1fe3250 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -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 ] } diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 8f30abd09f..6a76892246 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -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 diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor index 8b05af691d..9e898450cc 100755 --- a/core/optimizer/optimizer.factor +++ b/core/optimizer/optimizer.factor @@ -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 diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index a4f5aaab95..10a9fda3ea 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -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 diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor old mode 100644 new mode 100755 index 46ff9a1ada..d453ee60ca --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -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 ) diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index e8efc11c32..f19a2127a5 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -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 diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index a3e925338f..00e39be2ba 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -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 ) + + { "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 ] } - } ; + + 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 ) contents eval ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: cat ( file -- ) 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 -! dup dispose process-stream-process wait-for-process -! zero? not -! [ "Bootstrap error" print "../boot-log" cat "bootstrap error" throw ] -! when - - [ - bootstrap - 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 ; + + "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 diff --git a/extra/builder/server/server.factor b/extra/builder/server/server.factor index 672de1e47d..f3ec349557 100644 --- a/extra/builder/server/server.factor +++ b/extra/builder/server/server.factor @@ -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 ; diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index c18395acc9..7412dd9b36 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -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 diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor new file mode 100644 index 0000000000..b3b88874b0 --- /dev/null +++ b/extra/builder/util/util.factor @@ -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* 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 ) contents eval ; + +: cat ( file -- ) contents print ; + +: run-or-bail ( desc quot -- ) + [ [ try-process ] curry ] + [ [ throw ] compose ] + bi* + recover ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/extra/const/const.factor b/extra/const/const.factor deleted file mode 100644 index 8efef7e372..0000000000 --- a/extra/const/const.factor +++ /dev/null @@ -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 ; diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor index 37f3812d2d..f9b4c8648d 100755 --- a/extra/delegate/protocols/protocols.factor +++ b/extra/delegate/protocols/protocols.factor @@ -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 ; diff --git a/extra/http/http.factor b/extra/http/http.factor index 755f36a538..5c4dae94c7 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -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 diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor index 2a35ed08f8..ae0e058490 100755 --- a/extra/icfp/2006/2006.factor +++ b/extra/icfp/2006/2006.factor @@ -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 ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index cbece818c9..6e6d79d8a4 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -119,7 +119,9 @@ HOOK: process-stream* io-backend ( desc -- stream process ) TUPLE: process-stream process ; : ( 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 ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index c0861788b6..c14b11029b 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -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 ( -- ) [ diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index f3f78fbb88..475a4ddef6 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -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 ] with-descriptor diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index c2f14c21bb..cd9bb9baef 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -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 diff --git a/extra/io/windows/pipes/authors.txt b/extra/io/windows/nt/pipes/authors.txt similarity index 100% rename from extra/io/windows/pipes/authors.txt rename to extra/io/windows/nt/pipes/authors.txt diff --git a/extra/io/windows/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor similarity index 74% rename from extra/io/windows/pipes/pipes.factor rename to extra/io/windows/nt/pipes/pipes.factor index 8c2acc4009..9591063609 100755 --- a/extra/io/windows/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -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 ; : ( -- pipe ) unique-pipe-name ; + +! /dev/null simulation +: null-input ( -- pipe ) + + dup pipe-out CloseHandle drop + pipe-in ; + +: null-output ( -- 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 ; diff --git a/extra/math/analysis/analysis.factor b/extra/math/analysis/analysis.factor old mode 100644 new mode 100755 index a41281d779..0b4b14ce54 --- a/extra/math/analysis/analysis.factor +++ b/extra/math/analysis/analysis.factor @@ -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 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 ) [ diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index 729281e81b..ebf14417c0 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -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 % ; M: #r> node>quot nip node-out-d length \ r> % ; -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 [ diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index 275deee994..3ca1c72296 100755 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -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 ; diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 27aac1202e..47bc16e029 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -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 construct-empty ; + +: send ( email -- ) + { email-body email-subject email-to email-from } get-slots + send-simple-message ; \ No newline at end of file diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index b6c0ef3ecc..75ae377ea7 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -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 diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index e4794452c7..082a27317a 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -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 ; diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 70a9c781a2..1014d3ad7e 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -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 ; diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index c579d1fdfd..3af3d927d7 100644 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -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* ; diff --git a/extra/x11/clipboard/clipboard.factor b/extra/x11/clipboard/clipboard.factor old mode 100644 new mode 100755 index 5978ee6f7f..eb4191ebb1 --- a/extra/x11/clipboard/clipboard.factor +++ b/extra/x11/clipboard/clipboard.factor @@ -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