diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index a99e547b31..4bf4cf88f0 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -11,6 +11,8 @@ compiler.tree.normalization compiler.tree.cleanup compiler.tree.propagation compiler.tree.propagation.info +compiler.tree.escape-analysis +compiler.tree.tuple-unboxing compiler.tree.def-use compiler.tree.builder compiler.tree.optimizer @@ -209,6 +211,8 @@ SYMBOL: node-count normalize propagate cleanup + escape-analysis + unbox-tuples apply-identities compute-def-use remove-dead-code diff --git a/basis/compiler/tree/def-use/def-use.factor b/basis/compiler/tree/def-use/def-use.factor index 21e79eb6c4..872b6131c9 100644 --- a/basis/compiler/tree/def-use/def-use.factor +++ b/basis/compiler/tree/def-use/def-use.factor @@ -21,7 +21,7 @@ TUPLE: definition value node uses ; ERROR: no-def-error value ; : def-of ( value -- definition ) - dup def-use get at* [ nip ] [ no-def-error ] if ; + def-use get ?at [ no-def-error ] unless ; ERROR: multiple-defs-error ; diff --git a/basis/compiler/tree/def-use/simplified/simplified-tests.factor b/basis/compiler/tree/def-use/simplified/simplified-tests.factor index a1a768d429..72c7e4c60c 100644 --- a/basis/compiler/tree/def-use/simplified/simplified-tests.factor +++ b/basis/compiler/tree/def-use/simplified/simplified-tests.factor @@ -1,6 +1,6 @@ USING: kernel tools.test compiler.tree compiler.tree.builder -compiler.tree.def-use compiler.tree.def-use.simplified accessors -sequences sorting classes ; +compiler.tree.recursive compiler.tree.def-use +compiler.tree.def-use.simplified accessors sequences sorting classes ; IN: compiler.tree.def-use.simplified [ { #call #return } ] [ @@ -8,3 +8,17 @@ IN: compiler.tree.def-use.simplified first out-d>> first actually-used-by [ node>> class ] map natural-sort ] unit-test + +: word-1 ( a -- b ) dup [ word-1 ] when ; inline recursive + +[ { #introduce } ] [ + [ word-1 ] build-tree analyze-recursive compute-def-use + last in-d>> first actually-defined-by + [ node>> class ] map natural-sort +] unit-test + +[ { #if #return } ] [ + [ word-1 ] build-tree analyze-recursive compute-def-use + first out-d>> first actually-used-by + [ node>> class ] map natural-sort +] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/def-use/simplified/simplified.factor b/basis/compiler/tree/def-use/simplified/simplified.factor index 9b2a2038da..c2fb74c97e 100644 --- a/basis/compiler/tree/def-use/simplified/simplified.factor +++ b/basis/compiler/tree/def-use/simplified/simplified.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences kernel fry vectors -compiler.tree compiler.tree.def-use ; +USING: sequences kernel fry vectors accessors namespaces assocs sets +stack-checker.branches compiler.tree compiler.tree.def-use ; IN: compiler.tree.def-use.simplified ! Simplified def-use follows chains of copies. @@ -9,32 +9,85 @@ IN: compiler.tree.def-use.simplified ! A 'real' usage is a usage of a value that is not a #renaming. TUPLE: real-usage value node ; -! Def -GENERIC: actually-defined-by* ( value node -- real-usage ) + + +! Def +GENERIC: actually-defined-by* ( value node -- ) + +: (actually-defined-by) ( value -- ) + [ dup defined-by actually-defined-by* ] if-not-visited ; M: #renaming actually-defined-by* - inputs/outputs swap [ index ] dip nth actually-defined-by ; + inputs/outputs swap [ index ] dip nth (actually-defined-by) ; -M: #return-recursive actually-defined-by* real-usage boa ; +M: #call-recursive actually-defined-by* + [ out-d>> index ] [ label>> return>> in-d>> nth ] bi + (actually-defined-by) ; -M: node actually-defined-by* real-usage boa ; +M: #enter-recursive actually-defined-by* + [ out-d>> index ] keep + [ in-d>> nth (actually-defined-by) ] + [ label>> calls>> [ node>> in-d>> nth (actually-defined-by) ] with each ] 2bi ; + +M: #phi actually-defined-by* + [ out-d>> index ] [ phi-in-d>> ] bi + [ + nth dup +bottom+ eq? + [ drop ] [ (actually-defined-by) ] if + ] with each ; + +M: node actually-defined-by* + real-usage boa accum get conjoin ; + +: actually-defined-by ( value -- real-usages ) + [ (actually-defined-by) ] with-simplified-def-use ; ! Use -GENERIC# actually-used-by* 1 ( value node accum -- ) +GENERIC: actually-used-by* ( value node -- ) -: (actually-used-by) ( value accum -- ) - [ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ; +: (actually-used-by) ( value -- ) + [ dup used-by [ actually-used-by* ] with each ] if-not-visited ; M: #renaming actually-used-by* - [ inputs/outputs [ indices ] dip nths ] dip - '[ _ (actually-used-by) ] each ; + inputs/outputs [ indices ] dip nths + [ (actually-used-by) ] each ; -M: #return-recursive actually-used-by* [ real-usage boa ] dip push ; +M: #return-recursive actually-used-by* + [ in-d>> index ] keep + [ out-d>> nth (actually-used-by) ] + [ label>> calls>> [ node>> out-d>> nth (actually-used-by) ] with each ] 2bi ; -M: node actually-used-by* [ real-usage boa ] dip push ; +M: #call-recursive actually-used-by* + [ in-d>> index ] [ label>> enter-out>> nth ] bi + (actually-used-by) ; + +M: #enter-recursive actually-used-by* + [ in-d>> index ] [ out-d>> nth ] bi (actually-used-by) ; + +M: #phi actually-used-by* + [ phi-in-d>> [ index ] with map-find drop ] [ out-d>> nth ] bi + (actually-used-by) ; + +M: #recursive actually-used-by* 2drop ; + +M: node actually-used-by* + real-usage boa accum get conjoin ; : actually-used-by ( value -- real-usages ) - 10 [ (actually-used-by) ] keep ; + [ (actually-used-by) ] with-simplified-def-use ; diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index 7d40bf3fc1..7b972c5160 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -1,11 +1,10 @@ ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private tools.test math math.partial-dispatch -math.private accessors slots.private sequences sequences.private strings sbufs -compiler.tree.builder -compiler.tree.normalization -compiler.tree.debugger -alien.accessors layouts combinators byte-arrays ; +prettyprint math.private accessors slots.private sequences +sequences.private strings sbufs compiler.tree.builder +compiler.tree.normalization compiler.tree.debugger alien.accessors +layouts combinators byte-arrays ; IN: compiler.tree.modular-arithmetic.tests : test-modular-arithmetic ( quot -- quot' ) @@ -93,8 +92,6 @@ TUPLE: declared-fixnum { x fixnum } ; [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined? ] unit-test - - [ t ] [ [ { integer } declare [ 256 mod ] map @@ -140,6 +137,11 @@ TUPLE: declared-fixnum { x fixnum } ; [ [ >fixnum 255 fixnum-bitand ] ] [ [ >integer 256 rem ] test-modular-arithmetic ] unit-test +[ t ] [ + [ { fixnum fixnum } declare + [ 1 + >fixnum ] [ 2 + >fixnum ] bi ] + { >fixnum } inlined? +] unit-test + [ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-1 ] ] [ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-1 ] test-modular-arithmetic ] unit-test @@ -176,3 +178,83 @@ cell { [ 0 10 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ] { >fixnum } inlined? ] unit-test + +[ f ] [ [ + >fixnum ] { >fixnum } inlined? ] unit-test + +[ t ] [ + [ >integer [ >fixnum ] [ >fixnum ] bi ] + { >integer } inlined? +] unit-test + +[ f ] [ + [ >integer [ >fixnum ] [ >fixnum ] bi ] + { >fixnum } inlined? +] unit-test + +[ t ] [ + [ >integer [ 2 + >fixnum ] [ 3 + >fixnum ] bi ] + { >integer } inlined? +] unit-test + +[ f ] [ + [ >integer [ 2 + >fixnum ] [ 3 + >fixnum ] bi ] + { >fixnum } inlined? +] unit-test + +[ f ] [ + [ [ { fixnum } declare 2 fixnum+ ] dip [ >fixnum 2 - ] [ ] if ] + { fixnum+ } inlined? +] unit-test + +[ t ] [ + [ { fixnum boolean } declare [ 1 + ] [ "HI" throw ] if >fixnum ] + { fixnum+ >fixnum } inlined? +] unit-test + +[ t ] [ + [ { fixnum boolean } declare [ 1 + ] [ drop 5 ] if >fixnum ] + { fixnum+ >fixnum } inlined? +] unit-test + +[ t ] [ + [ { fixnum boolean } declare [ 1 + ] [ 2 + ] if >fixnum ] + { fixnum+ >fixnum } inlined? +] unit-test + +[ [ [ 1 ] [ 4 ] if ] ] [ + [ [ 1.5 ] [ 4 ] if >fixnum ] test-modular-arithmetic +] unit-test + +[ [ [ 1 ] [ 2 ] if ] ] [ + [ [ 1.5 ] [ 2.3 ] if >fixnum ] test-modular-arithmetic +] unit-test + +[ f ] [ + [ { fixnum fixnum boolean } declare [ [ 3 * ] [ 1 + ] dip ] [ [ 4 - ] [ 2 + ] dip ] if >fixnum ] + { fixnum+ >fixnum } inlined? +] unit-test + +[ t ] [ + [ 0 1000 [ 1 + dup >fixnum . ] times drop ] + { fixnum+ >fixnum } inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare 3 + [ 1000 ] dip [ >fixnum . ] curry times ] + { fixnum+ >fixnum } inlined? +] unit-test + +[ t ] [ + [ 0 1000 [ 1 + ] times >fixnum ] + { fixnum+ >fixnum } inlined? +] unit-test + +[ f ] [ + [ f >fixnum ] + { >fixnum } inlined? +] unit-test + +[ f ] [ + [ [ >fixnum ] 2dip set-alien-unsigned-1 ] + { >fixnum } inlined? +] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor index 148286faba..d97295d0f1 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: math math.partial-dispatch namespaces sequences sets -accessors assocs words kernel memoize fry combinators +USING: math math.private math.partial-dispatch namespaces sequences +sets accessors assocs words kernel memoize fry combinators combinators.short-circuit layouts alien.accessors compiler.tree compiler.tree.combinators +compiler.tree.propagation.info compiler.tree.def-use compiler.tree.def-use.simplified compiler.tree.late-optimizations ; @@ -19,17 +20,24 @@ IN: compiler.tree.modular-arithmetic ! ==> ! [ >fixnum ] bi@ fixnum+fast +! Words where the low-order bits of the output only depends on the +! low-order bits of the input. If the output is only used for its +! low-order bits, then the word can be converted into a form that is +! cheaper to compute. { + - * bitand bitor bitxor } [ [ t "modular-arithmetic" set-word-prop ] each-integer-derived-op ] each -{ bitand bitor bitxor bitnot } +{ bitand bitor bitxor bitnot >integer } [ t "modular-arithmetic" set-word-prop ] each +! Words that only use the low-order bits of their input. If the input +! is a modular arithmetic word, then the input can be converted into +! a form that is cheaper to compute. { - >fixnum + >fixnum bignum>fixnum float>fixnum set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2 set-alien-signed-2 } @@ -38,80 +46,138 @@ cell 8 = [ ] when [ t "low-order" set-word-prop ] each -SYMBOL: modularize-values +! Values which only have their low-order bits used. This set starts out +! big and is gradually refined. +SYMBOL: modular-values : modular-value? ( value -- ? ) - modularize-values get key? ; + modular-values get key? ; -: modularize-value ( value -- ) modularize-values get conjoin ; +: modular-value ( value -- ) + modular-values get conjoin ; -GENERIC: maybe-modularize* ( value node -- ) +! Values which are known to be fixnums. +SYMBOL: fixnum-values -: maybe-modularize ( value -- ) - actually-defined-by [ value>> ] [ node>> ] bi - over actually-used-by length 1 = [ - maybe-modularize* - ] [ 2drop ] if ; +: fixnum-value? ( value -- ? ) + fixnum-values get key? ; -M: #call maybe-modularize* - dup word>> "modular-arithmetic" word-prop [ - [ modularize-value ] - [ in-d>> [ maybe-modularize ] each ] bi* - ] [ 2drop ] if ; +: fixnum-value ( value -- ) + fixnum-values get conjoin ; -M: node maybe-modularize* 2drop ; +GENERIC: compute-modular-candidates* ( node -- ) -GENERIC: compute-modularized-values* ( node -- ) +M: #push compute-modular-candidates* + [ out-d>> first ] [ literal>> ] bi + real? [ [ modular-value ] [ fixnum-value ] bi ] [ drop ] if ; -M: #call compute-modularized-values* - dup word>> "low-order" word-prop - [ in-d>> first maybe-modularize ] [ drop ] if ; +M: #call compute-modular-candidates* + { + { + [ dup word>> "modular-arithmetic" word-prop ] + [ out-d>> first [ modular-value ] [ fixnum-value ] bi ] + } + { + [ dup word>> "low-order" word-prop ] + [ in-d>> first modular-value ] + } + [ drop ] + } cond ; -M: node compute-modularized-values* drop ; +M: node compute-modular-candidates* + drop ; -: compute-modularized-values ( nodes -- ) - [ compute-modularized-values* ] each-node ; +: compute-modular-candidates ( nodes -- ) + H{ } clone modular-values set + H{ } clone fixnum-values set + [ compute-modular-candidates* ] each-node ; + +GENERIC: only-reads-low-order? ( node -- ? ) + +M: #call only-reads-low-order? + { + [ word>> "low-order" word-prop ] + [ + { + [ word>> "modular-arithmetic" word-prop ] + [ out-d>> first modular-values get key? ] + } 1&& + ] + } 1|| ; + +M: node only-reads-low-order? drop f ; + +SYMBOL: changed? + +: only-used-as-low-order? ( value -- ? ) + actually-used-by [ node>> only-reads-low-order? ] all? ; + +: (compute-modular-values) ( -- ) + modular-values get keys [ + dup only-used-as-low-order? + [ drop ] [ modular-values get delete-at changed? on ] if + ] each ; + +: compute-modular-values ( -- ) + [ changed? off (compute-modular-values) changed? get ] loop ; GENERIC: optimize-modular-arithmetic* ( node -- nodes ) +M: #push optimize-modular-arithmetic* + dup [ out-d>> first modular-value? ] [ literal>> real? ] bi and + [ [ >fixnum ] change-literal ] when ; + : redundant->fixnum? ( #call -- ? ) - in-d>> first actually-defined-by value>> modular-value? ; + in-d>> first actually-defined-by + [ value>> { [ modular-value? ] [ fixnum-value? ] } 1&& ] all? ; : optimize->fixnum ( #call -- nodes ) dup redundant->fixnum? [ drop f ] when ; +: should-be->fixnum? ( #call -- ? ) + out-d>> first modular-value? ; + : optimize->integer ( #call -- nodes ) - dup out-d>> first actually-used-by dup length 1 = [ - first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&& - [ drop { } ] when - ] [ drop ] if ; + dup should-be->fixnum? [ \ >fixnum >>word ] when ; MEMO: fixnum-coercion ( flags -- nodes ) + ! flags indicate which input parameters are already known to be fixnums, + ! and don't need a coercion as a result. [ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ; +: modular-value-info ( #call -- alist ) + [ in-d>> ] [ out-d>> ] bi append + fixnum '[ _ ] { } map>assoc ; + : optimize-modular-op ( #call -- nodes ) dup out-d>> first modular-value? [ [ in-d>> ] [ word>> integer-op-input-classes ] [ ] tri [ [ - [ actually-defined-by value>> modular-value? ] + [ actually-defined-by [ value>> modular-value? ] all? ] [ fixnum eq? ] bi* or ] 2map fixnum-coercion ] [ [ modular-variant ] change-word ] bi* suffix ] when ; +: optimize-low-order-op ( #call -- nodes ) + dup in-d>> first fixnum-value? [ + [ ] [ in-d>> first ] [ info>> ] tri + [ drop fixnum ] change-at + ] when ; + M: #call optimize-modular-arithmetic* dup word>> { - { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] } + { [ dup { >fixnum bignum>fixnum float>fixnum } memq? ] [ drop optimize->fixnum ] } { [ dup \ >integer eq? ] [ drop optimize->integer ] } { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] } + { [ dup "low-order" word-prop ] [ drop optimize-low-order-op ] } [ drop ] } cond ; M: node optimize-modular-arithmetic* ; : optimize-modular-arithmetic ( nodes -- nodes' ) - H{ } clone modularize-values set - dup compute-modularized-values + dup compute-modular-candidates compute-modular-values [ optimize-modular-arithmetic* ] map-nodes ; diff --git a/basis/multiline/multiline-docs.factor b/basis/multiline/multiline-docs.factor index 4782571d4a..1b7ca3fdaa 100644 --- a/basis/multiline/multiline-docs.factor +++ b/basis/multiline/multiline-docs.factor @@ -18,6 +18,16 @@ HELP: /* "" } ; +HELP: HEREDOC: +{ $syntax "HEREDOC: marker\n...text...marker" } +{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "" "a string" } } +{ $description "A multiline string syntax with a user-specified terminating delimiter. HEREDOC: reads the next word, and uses it as the 'close quote'. All input from the beginning of the HEREDOC:'s next line, until the first appearance of the word's name, becomes a string. The terminating word does not need to be at the beginning of a line.\n\nThe HEREDOC: line should not have anything after the delimiting word. The delimiting word should be an alphanumeric token. It should not be, as in some other languages, a \"quoted string\"." } +{ $examples + { $example "USING: heredoc ;" "HEREDOC: END\nx\nEND" "! \"x\\n\"" } + { $example "HEREDOC: END\nxEND" "! \"x\"" } + { $example "2 5 HEREDOC: zap\nfoo\nbarzap subseq" "! \"o\\nb\"" } +} ; + { POSTPONE: <" POSTPONE: STRING: } related-words HELP: parse-multiline-string @@ -29,6 +39,7 @@ ARTICLE: "multiline" "Multiline" "Multiline strings:" { $subsection POSTPONE: STRING: } { $subsection POSTPONE: <" } +{ $subsection POSTPONE: HEREDOC: } "Multiline comments:" { $subsection POSTPONE: /* } "Writing new multiline parsing words:" diff --git a/basis/multiline/multiline-tests.factor b/basis/multiline/multiline-tests.factor index 153b6cedbe..2458589d27 100644 --- a/basis/multiline/multiline-tests.factor +++ b/basis/multiline/multiline-tests.factor @@ -19,3 +19,43 @@ world"> ] unit-test [ "\nhi" ] [ <" hi"> ] unit-test + + +! HEREDOC: + +[ "foo\nbar\n" ] [ HEREDOC: END +foo +bar +END ] unit-test + +[ "foo\nbar" ] [ HEREDOC: END +foo +barEND ] unit-test + +[ "" ] [ HEREDOC: END +END ] unit-test + +[ " " ] [ HEREDOC: END + END ] unit-test + +[ "\n" ] [ HEREDOC: END + +END ] unit-test + +[ "x" ] [ HEREDOC: END +xEND ] unit-test + +[ "xyz " ] [ HEREDOC: END +xyz END ] unit-test + +[ "} ! * # \" «\n" ] [ HEREDOC: END +} ! * # " « +END ] unit-test + +[ 21 "foo\nbar" " HEREDOC: FOO\n FOO\n" 22 ] [ 21 HEREDOC: X +foo +barX HEREDOC: END ! mumble + HEREDOC: FOO + FOO +END 22 ] unit-test + diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index c0d109e3c5..e4334f1201 100644 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -27,7 +27,7 @@ SYNTAX: STRING: > :> text text [ end text i start* [| j | @@ -35,18 +35,21 @@ SYNTAX: STRING: ] [ text i short tail % CHAR: \n , lexer get next-line - 0 end (parse-multiline-string) + 0 end (scan-multiline-string) ] if* ] [ end unexpected-eof ] if ; +:: (parse-multiline-string) ( end-text skip-n-chars -- str ) + [ + lexer get + [ skip-n-chars + end-text (scan-multiline-string) ] + change-column drop + ] "" make ; + PRIVATE> : parse-multiline-string ( end-text -- str ) - [ - lexer get - [ 1 + swap (parse-multiline-string) ] - change-column drop - ] "" make ; + 1 (parse-multiline-string) ; SYNTAX: <" "\">" parse-multiline-string parsed ; @@ -61,3 +64,9 @@ SYNTAX: {" "\"}" parse-multiline-string parsed ; SYNTAX: /* "*/" parse-multiline-string drop ; + +SYNTAX: HEREDOC: + scan + lexer get next-line + 0 (parse-multiline-string) + parsed ; diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor index a23e4ecd74..e28083b2db 100644 --- a/core/byte-arrays/byte-arrays-tests.factor +++ b/core/byte-arrays/byte-arrays-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test byte-arrays sequences kernel ; +USING: tools.test byte-arrays sequences kernel math ; IN: byte-arrays.tests [ 6 B{ 1 2 3 } ] [ @@ -11,3 +11,7 @@ IN: byte-arrays.tests [ -10 B{ } resize-byte-array ] must-fail [ B{ 123 } ] [ 123 1byte-array ] unit-test + +[ B{ 123 } ] [ 123 0 B{ 0 } [ set-nth ] keep ] unit-test + +[ B{ 123 } ] [ 123 >bignum 0 B{ 0 } [ set-nth ] keep ] unit-test \ No newline at end of file diff --git a/core/io/streams/byte-array/byte-array-tests.factor b/core/io/streams/byte-array/byte-array-tests.factor index 43a8373232..3a08dd10d9 100644 --- a/core/io/streams/byte-array/byte-array-tests.factor +++ b/core/io/streams/byte-array/byte-array-tests.factor @@ -1,5 +1,5 @@ USING: tools.test io.streams.byte-array io.encodings.binary -io.encodings.utf8 io kernel arrays strings namespaces ; +io.encodings.utf8 io kernel arrays strings namespaces math ; [ B{ } ] [ B{ } binary [ contents ] with-byte-reader ] unit-test [ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test @@ -28,3 +28,8 @@ io.encodings.utf8 io kernel arrays strings namespaces ; read1 ] with-byte-reader ] unit-test + +! Overly aggressive compiler optimizations +[ B{ 123 } ] [ + binary [ 123 >bignum write1 ] with-byte-writer +] unit-test \ No newline at end of file diff --git a/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor index ca57de822f..9562e42c4e 100644 --- a/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor +++ b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor @@ -36,8 +36,7 @@ C-STRUCT: yuv_buffer 255 min 0 max ; inline : stride ( line yuv -- uvy yy ) - [ yuv_buffer-uv_stride swap 2/ * >fixnum ] - [ yuv_buffer-y_stride * >fixnum ] 2bi ; inline + [ yuv_buffer-uv_stride swap 2/ * ] [ yuv_buffer-y_stride * ] 2bi ; inline : compute-y ( yuv uvy yy x -- y ) + >fixnum nip swap yuv_buffer-y swap alien-unsigned-1 16 - ; inline @@ -74,16 +73,16 @@ C-STRUCT: yuv_buffer drop ; inline : yuv>rgb-pixel ( index rgb yuv uvy yy x -- index ) - compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline + compute-yuv compute-rgb store-rgb 3 + ; inline : yuv>rgb-row ( index rgb yuv y -- index ) over stride - pick yuv_buffer-y_width >fixnum + pick yuv_buffer-y_width [ yuv>rgb-pixel ] with with with with each ; inline : yuv>rgb ( rgb yuv -- ) [ 0 ] 2dip - dup yuv_buffer-y_height >fixnum + dup yuv_buffer-y_height [ yuv>rgb-row ] with with each drop ; diff --git a/unmaintained/multi-methods/authors.txt b/extra/multi-methods/authors.txt similarity index 100% rename from unmaintained/multi-methods/authors.txt rename to extra/multi-methods/authors.txt diff --git a/unmaintained/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor similarity index 98% rename from unmaintained/multi-methods/multi-methods.factor rename to extra/multi-methods/multi-methods.factor index 17f0de120e..d3e1d443aa 100755 --- a/unmaintained/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -21,7 +21,7 @@ SYMBOL: total : canonicalize-specializer-1 ( specializer -- specializer' ) [ [ class? ] filter - [ length [ 1+ neg ] map ] keep zip + [ length [ 1 + neg ] map ] keep zip [ length args [ max ] change ] keep ] [ @@ -104,7 +104,7 @@ SYMBOL: total { 0 [ [ dup ] ] } { 1 [ [ over ] ] } { 2 [ [ pick ] ] } - [ 1- picker [ dip swap ] curry ] + [ 1 - picker [ dip swap ] curry ] } case ; : (multi-predicate) ( class picker -- quot ) diff --git a/unmaintained/multi-methods/summary.txt b/extra/multi-methods/summary.txt similarity index 100% rename from unmaintained/multi-methods/summary.txt rename to extra/multi-methods/summary.txt diff --git a/unmaintained/multi-methods/tags.txt b/extra/multi-methods/tags.txt similarity index 100% rename from unmaintained/multi-methods/tags.txt rename to extra/multi-methods/tags.txt diff --git a/unmaintained/multi-methods/tests/canonicalize.factor b/extra/multi-methods/tests/canonicalize.factor similarity index 100% rename from unmaintained/multi-methods/tests/canonicalize.factor rename to extra/multi-methods/tests/canonicalize.factor diff --git a/unmaintained/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor similarity index 100% rename from unmaintained/multi-methods/tests/definitions.factor rename to extra/multi-methods/tests/definitions.factor diff --git a/unmaintained/multi-methods/tests/legacy.factor b/extra/multi-methods/tests/legacy.factor similarity index 100% rename from unmaintained/multi-methods/tests/legacy.factor rename to extra/multi-methods/tests/legacy.factor diff --git a/unmaintained/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor similarity index 76% rename from unmaintained/multi-methods/tests/syntax.factor rename to extra/multi-methods/tests/syntax.factor index cc073099d8..065543344f 100644 --- a/unmaintained/multi-methods/tests/syntax.factor +++ b/extra/multi-methods/tests/syntax.factor @@ -2,8 +2,9 @@ IN: multi-methods.tests USING: multi-methods tools.test math sequences namespaces system kernel strings definitions prettyprint debugger arrays hashtables continuations classes assocs accessors see ; +RENAME: GENERIC: multi-methods => multi-methods:GENERIC: -GENERIC: first-test ( -- ) +multi-methods:GENERIC: first-test ( -- ) [ t ] [ \ first-test generic? ] unit-test @@ -13,14 +14,14 @@ SINGLETON: paper INSTANCE: paper thing SINGLETON: scissors INSTANCE: scissors thing SINGLETON: rock INSTANCE: rock thing -GENERIC: beats? ( obj1 obj2 -- ? ) +multi-methods:GENERIC: beats? ( obj1 obj2 -- ? ) -METHOD: beats? { paper scissors } t ; -METHOD: beats? { scissors rock } t ; -METHOD: beats? { rock paper } t ; -METHOD: beats? { thing thing } f ; +METHOD: beats? { paper scissors } 2drop t ; +METHOD: beats? { scissors rock } 2drop t ; +METHOD: beats? { rock paper } 2drop t ; +METHOD: beats? { thing thing } 2drop f ; -: play ( obj1 obj2 -- ? ) beats? 2nip ; +: play ( obj1 obj2 -- ? ) beats? ; [ { } 3 play ] must-fail [ t ] [ error get no-method? ] unit-test @@ -34,7 +35,7 @@ METHOD: beats? { thing thing } f ; SYMBOL: some-var -GENERIC: hook-test ( -- obj ) +multi-methods:GENERIC: hook-test ( obj -- obj ) METHOD: hook-test { array { some-var array } } reverse ; METHOD: hook-test { { some-var array } } class ; @@ -57,7 +58,7 @@ TUPLE: busted-1 ; TUPLE: busted-2 ; INSTANCE: busted-2 busted TUPLE: busted-3 ; -GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 ) +multi-methods:GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 ) METHOD: busted-sort { busted-1 busted-2 } ; METHOD: busted-sort { busted-2 busted-3 } ; diff --git a/unmaintained/multi-methods/tests/topological-sort.factor b/extra/multi-methods/tests/topological-sort.factor similarity index 100% rename from unmaintained/multi-methods/tests/topological-sort.factor rename to extra/multi-methods/tests/topological-sort.factor