From b29da2ae483ca4aeec64b7cdeb768d71be091fcd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 15 Aug 2009 14:02:18 -0500 Subject: [PATCH 01/16] fix docs --- core/sequences/sequences-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 2a52384180..258b484764 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1392,7 +1392,7 @@ $nl "More elaborate counted loops can be performed with " { $link "math.ranges" } "." ; ARTICLE: "sequences-if" "Control flow with sequences" -"To reduce the boilerplate of checking if a sequence is empty or a number is zero, several combinators are provided." +"To reduce the boilerplate of checking if a sequence is empty, several combinators are provided." $nl "Checking if a sequence is empty:" { $subsection if-empty } From b239c3b6056689215778972d32940670e03bc21a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 15 Aug 2009 14:25:16 -0500 Subject: [PATCH 02/16] fix factor.sh for a couple of modes that nobody has used in a long time --- build-support/factor.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index d5b8bd5411..b179811bda 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -487,12 +487,12 @@ update_bootstrap() { } refresh_image() { - ./$FACTOR_BINARY -script -e="USE: vocabs.loader USE: system refresh-all USE: memory save 0 exit" + ./$FACTOR_BINARY -script -e="USING: vocabs.loader system memory ; refresh-all USE: memory save 0 exit" check_ret factor } make_boot_image() { - ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: system USE: bootstrap.image make-image save 0 exit" + ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USING: system bootstrap.image memory ; make-image save 0 exit" check_ret factor } From aeb33f5f15a074238eaeb7cfaa4a472f7d4bfc63 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 15 Aug 2009 18:42:41 -0500 Subject: [PATCH 03/16] compiler.tree.modular-arithmetic: stronger optimization handles > 1 usages case as well as values defined and used in loops. Eliminates 5 out of 8 >fixnum calls in benchmark.yuv-to-rgb --- basis/compiler/tree/debugger/debugger.factor | 4 + basis/compiler/tree/def-use/def-use.factor | 2 +- .../simplified/simplified-tests.factor | 18 ++- .../tree/def-use/simplified/simplified.factor | 89 ++++++++--- .../modular-arithmetic-tests.factor | 87 ++++++++++- .../modular-arithmetic.factor | 146 +++++++++++++----- extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor | 9 +- 7 files changed, 287 insertions(+), 68 deletions(-) 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..9c3f98d412 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,74 @@ 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 + diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor index 148286faba..84f11aeb47 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,148 @@ 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? [ + [ >fixnum ] change-literal + ] when ; + +: input-will-be-fixnum? ( #call -- ? ) + in-d>> first actually-defined-by + [ value>> { [ modular-value? ] [ fixnum-value? ] } 1&& ] all? ; + +: output-will-be-coerced? ( #call -- ? ) + out-d>> first modular-value? ; + : redundant->fixnum? ( #call -- ? ) - in-d>> first actually-defined-by value>> modular-value? ; + { + [ input-will-be-fixnum? ] + [ output-will-be-coerced? ] + } 1|| ; : 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 modular-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/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 ; From a742145fd974fa13f7f12b8e24f449415a4b95e7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Aug 2009 01:20:25 -0500 Subject: [PATCH 04/16] compiler.tree.modular-arithmetic: >fixnum elimination and value info annotations were too aggressive --- .../modular-arithmetic-tests.factor | 9 +++++++++ .../modular-arithmetic.factor | 20 +++++-------------- core/byte-arrays/byte-arrays-tests.factor | 6 +++++- .../byte-array/byte-array-tests.factor | 7 ++++++- 4 files changed, 25 insertions(+), 17 deletions(-) diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index 9c3f98d412..7b972c5160 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -249,3 +249,12 @@ cell { { 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 84f11aeb47..d97295d0f1 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor @@ -124,22 +124,12 @@ SYMBOL: changed? GENERIC: optimize-modular-arithmetic* ( node -- nodes ) M: #push optimize-modular-arithmetic* - dup out-d>> first modular-value? [ - [ >fixnum ] change-literal - ] when ; - -: input-will-be-fixnum? ( #call -- ? ) - in-d>> first actually-defined-by - [ value>> { [ modular-value? ] [ fixnum-value? ] } 1&& ] all? ; - -: output-will-be-coerced? ( #call -- ? ) - out-d>> first modular-value? ; + dup [ out-d>> first modular-value? ] [ literal>> real? ] bi and + [ [ >fixnum ] change-literal ] when ; : redundant->fixnum? ( #call -- ? ) - { - [ input-will-be-fixnum? ] - [ output-will-be-coerced? ] - } 1|| ; + in-d>> first actually-defined-by + [ value>> { [ modular-value? ] [ fixnum-value? ] } 1&& ] all? ; : optimize->fixnum ( #call -- nodes ) dup redundant->fixnum? [ drop f ] when ; @@ -172,7 +162,7 @@ MEMO: fixnum-coercion ( flags -- nodes ) ] when ; : optimize-low-order-op ( #call -- nodes ) - dup in-d>> first modular-value? [ + dup in-d>> first fixnum-value? [ [ ] [ in-d>> first ] [ info>> ] tri [ drop fixnum ] change-at ] when ; 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 From 661bef0ed0fd877572c16918b9eda25c77b77a72 Mon Sep 17 00:00:00 2001 From: Mitchell N Charity Date: Mon, 17 Aug 2009 14:52:15 -0400 Subject: [PATCH 05/16] multi-methods: fix (1+ and 1- were recently removed) multi-methods: fix tests (ambiguity and incorrect stack effect) --- .../multi-methods/multi-methods.factor | 4 ++-- .../multi-methods/tests/syntax.factor | 19 ++++++++++--------- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/unmaintained/multi-methods/multi-methods.factor b/unmaintained/multi-methods/multi-methods.factor index 17f0de120e..d3e1d443aa 100755 --- a/unmaintained/multi-methods/multi-methods.factor +++ b/unmaintained/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/tests/syntax.factor b/unmaintained/multi-methods/tests/syntax.factor index cc073099d8..065543344f 100644 --- a/unmaintained/multi-methods/tests/syntax.factor +++ b/unmaintained/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 } ; From c28e19c863a595d38973492cf8ac701bbb74a17a Mon Sep 17 00:00:00 2001 From: Mitchell N Charity Date: Mon, 17 Aug 2009 15:32:44 -0400 Subject: [PATCH 06/16] multi-methods: mv from unmaintained/ to extra/ --- {unmaintained => extra}/multi-methods/authors.txt | 0 {unmaintained => extra}/multi-methods/multi-methods.factor | 0 {unmaintained => extra}/multi-methods/summary.txt | 0 {unmaintained => extra}/multi-methods/tags.txt | 0 {unmaintained => extra}/multi-methods/tests/canonicalize.factor | 0 {unmaintained => extra}/multi-methods/tests/definitions.factor | 0 {unmaintained => extra}/multi-methods/tests/legacy.factor | 0 {unmaintained => extra}/multi-methods/tests/syntax.factor | 0 .../multi-methods/tests/topological-sort.factor | 0 9 files changed, 0 insertions(+), 0 deletions(-) rename {unmaintained => extra}/multi-methods/authors.txt (100%) rename {unmaintained => extra}/multi-methods/multi-methods.factor (100%) rename {unmaintained => extra}/multi-methods/summary.txt (100%) rename {unmaintained => extra}/multi-methods/tags.txt (100%) rename {unmaintained => extra}/multi-methods/tests/canonicalize.factor (100%) rename {unmaintained => extra}/multi-methods/tests/definitions.factor (100%) rename {unmaintained => extra}/multi-methods/tests/legacy.factor (100%) rename {unmaintained => extra}/multi-methods/tests/syntax.factor (100%) rename {unmaintained => extra}/multi-methods/tests/topological-sort.factor (100%) 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 100% rename from unmaintained/multi-methods/multi-methods.factor rename to extra/multi-methods/multi-methods.factor 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 100% rename from unmaintained/multi-methods/tests/syntax.factor rename to extra/multi-methods/tests/syntax.factor 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 From ea44aebfc56851a24d3076630c8b1d9f65c96c4e Mon Sep 17 00:00:00 2001 From: Mitchell N Charity Date: Mon, 17 Aug 2009 17:05:14 -0400 Subject: [PATCH 07/16] multiline: add HEREDOC: , slightly refactoring privates --- basis/multiline/multiline-docs.factor | 11 +++++++ basis/multiline/multiline-tests.factor | 40 ++++++++++++++++++++++++++ basis/multiline/multiline.factor | 23 ++++++++++----- 3 files changed, 67 insertions(+), 7 deletions(-) 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 ; From 45c0ef9a51736dd6758f49e9920f3678638b1abc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 17 Aug 2009 18:59:03 -0500 Subject: [PATCH 08/16] trivial factoring --- basis/sorting/functor/functor.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/sorting/functor/functor.factor b/basis/sorting/functor/functor.factor index 7f46af4c92..8e9ea6a9ea 100644 --- a/basis/sorting/functor/functor.factor +++ b/basis/sorting/functor/functor.factor @@ -10,7 +10,7 @@ NAME>=< DEFINES ${NAME}>=< WHERE -: NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ; +: NAME<=> ( obj1 obj2 -- <=> ) QUOT compare ; : NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ; ;FUNCTOR From f83ef740602d599ffc8f8d6db09fb4538e986356 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 17 Aug 2009 19:05:13 -0500 Subject: [PATCH 09/16] move IN: around --- extra/multi-methods/tests/canonicalize.factor | 2 +- extra/multi-methods/tests/definitions.factor | 2 +- extra/multi-methods/tests/legacy.factor | 2 +- extra/multi-methods/tests/syntax.factor | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/multi-methods/tests/canonicalize.factor b/extra/multi-methods/tests/canonicalize.factor index 91982de95c..6ddd5d63ce 100644 --- a/extra/multi-methods/tests/canonicalize.factor +++ b/extra/multi-methods/tests/canonicalize.factor @@ -1,6 +1,6 @@ -IN: multi-methods.tests USING: multi-methods tools.test math sequences namespaces system kernel strings ; +IN: multi-methods.tests [ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor index aa66f41d8d..888ded4155 100644 --- a/extra/multi-methods/tests/definitions.factor +++ b/extra/multi-methods/tests/definitions.factor @@ -1,6 +1,6 @@ -IN: multi-methods.tests USING: multi-methods tools.test math sequences namespaces system kernel strings words compiler.units quotations ; +IN: multi-methods.tests DEFER: fake \ fake H{ } clone "multi-methods" set-word-prop diff --git a/extra/multi-methods/tests/legacy.factor b/extra/multi-methods/tests/legacy.factor index b6d732643f..28bfa286b9 100644 --- a/extra/multi-methods/tests/legacy.factor +++ b/extra/multi-methods/tests/legacy.factor @@ -1,5 +1,5 @@ -IN: multi-methods.tests USING: math strings sequences tools.test ; +IN: multi-methods.tests GENERIC: legacy-test ( a -- b ) diff --git a/extra/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor index 065543344f..afe6037adc 100644 --- a/extra/multi-methods/tests/syntax.factor +++ b/extra/multi-methods/tests/syntax.factor @@ -1,8 +1,8 @@ -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: +IN: multi-methods.tests multi-methods:GENERIC: first-test ( -- ) From 73a11dcdfd67dae2747ca25d9c9d927597e9ebf1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 17 Aug 2009 19:24:14 -0500 Subject: [PATCH 10/16] fix unit tests for multi-methods --- extra/multi-methods/tests/definitions.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor index 888ded4155..a483a492b3 100644 --- a/extra/multi-methods/tests/definitions.factor +++ b/extra/multi-methods/tests/definitions.factor @@ -4,6 +4,7 @@ IN: multi-methods.tests DEFER: fake \ fake H{ } clone "multi-methods" set-word-prop +<< (( -- )) \ fake set-stack-effect >> [ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test From 27f4e8449fa21c029e0456bf10b2172a1a2ca35d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Aug 2009 20:12:05 -0500 Subject: [PATCH 11/16] rpn: new demo, simple RPN calculator that doesn't use Factor's evaluator reflectively --- .../specialized-arrays/functor/functor.factor | 18 ++++---- extra/rpn/authors.txt | 1 + extra/rpn/rpn.factor | 45 +++++++++++++++++++ extra/rpn/summary.txt | 1 + extra/rpn/tags.txt | 1 + 5 files changed, 57 insertions(+), 9 deletions(-) create mode 100644 extra/rpn/authors.txt create mode 100644 extra/rpn/rpn.factor create mode 100644 extra/rpn/summary.txt create mode 100644 extra/rpn/tags.txt diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 1c855be1a4..06b9aef17d 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -39,19 +39,19 @@ TUPLE: A dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless swap A boa ; inline -M: A clone [ length>> ] [ underlying>> clone ] bi A boa ; +M: A clone [ length>> ] [ underlying>> clone ] bi A boa ; inline -M: A length length>> ; +M: A length length>> ; inline -M: A nth-unsafe underlying>> NTH call ; +M: A nth-unsafe underlying>> NTH call ; inline -M: A set-nth-unsafe underlying>> SET-NTH call ; +M: A set-nth-unsafe underlying>> SET-NTH call ; inline -: >A ( seq -- specialized-array ) A new clone-like ; inline +: >A ( seq -- specialized-array ) A new clone-like ; -M: A like drop dup A instance? [ >A ] unless ; +M: A like drop dup A instance? [ >A ] unless ; inline -M: A new-sequence drop (A) ; +M: A new-sequence drop (A) ; inline M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ; @@ -60,9 +60,9 @@ M: A resize [ T heap-size * ] [ underlying>> ] bi* resize-byte-array ] 2bi - A boa ; + A boa ; inline -M: A byte-length underlying>> length ; +M: A byte-length underlying>> length ; inline M: A pprint-delims drop \ A{ \ } ; diff --git a/extra/rpn/authors.txt b/extra/rpn/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/rpn/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/rpn/rpn.factor b/extra/rpn/rpn.factor new file mode 100644 index 0000000000..7175746862 --- /dev/null +++ b/extra/rpn/rpn.factor @@ -0,0 +1,45 @@ +! Copyright (C) 2009 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators io kernel lists math math.parser +sequences splitting ; +IN: rpn + +SINGLETONS: add-insn sub-insn mul-insn div-insn ; +TUPLE: push-insn value ; + +GENERIC: eval-insn ( stack insn -- stack ) + +: binary-op ( stack quot: ( x y -- z ) -- stack ) + [ uncons uncons ] dip dip cons ; inline + +M: add-insn eval-insn drop [ + ] binary-op ; +M: sub-insn eval-insn drop [ - ] binary-op ; +M: mul-insn eval-insn drop [ * ] binary-op ; +M: div-insn eval-insn drop [ / ] binary-op ; +M: push-insn eval-insn value>> swons ; + +: rpn-tokenize ( string -- string' ) + " " split harvest sequence>list ; + +: rpn-parse ( string -- tokens ) + rpn-tokenize [ + { + { "+" [ add-insn ] } + { "-" [ sub-insn ] } + { "*" [ mul-insn ] } + { "/" [ div-insn ] } + [ string>number push-insn boa ] + } case + ] lmap ; + +: print-stack ( list -- ) + [ number>string print ] leach ; + +: rpn-eval ( tokens -- ) + nil [ eval-insn ] foldl print-stack ; + +: rpn ( -- ) + "RPN> " write flush + readln [ rpn-parse rpn-eval rpn ] when* ; + +MAIN: rpn diff --git a/extra/rpn/summary.txt b/extra/rpn/summary.txt new file mode 100644 index 0000000000..e6b4fe239b --- /dev/null +++ b/extra/rpn/summary.txt @@ -0,0 +1 @@ +Simple RPN calculator diff --git a/extra/rpn/tags.txt b/extra/rpn/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/rpn/tags.txt @@ -0,0 +1 @@ +demos From 3b6d622bb9f9fa58f8cec2f9b1b56620ae456055 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 17 Aug 2009 20:47:27 -0500 Subject: [PATCH 12/16] fix multiline docs --- basis/multiline/multiline-docs.factor | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/basis/multiline/multiline-docs.factor b/basis/multiline/multiline-docs.factor index 1b7ca3fdaa..0977acd1cd 100644 --- a/basis/multiline/multiline-docs.factor +++ b/basis/multiline/multiline-docs.factor @@ -23,9 +23,18 @@ HELP: HEREDOC: { $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\"" } + { $example "USING: multiline prettyprint ;" + "HEREDOC: END\nx\nEND ." + "\"x\\n\"" + } + { $example "USING: multiline prettyprint ;" + "HEREDOC: END\nxEND ." + "\"x\"" + } + { $example "USING: multiline prettyprint sequences ;" + "2 5 HEREDOC: zap\nfoo\nbarzap subseq ." + "\"o\\nb\"" + } } ; { POSTPONE: <" POSTPONE: STRING: } related-words From b3693e3c3bbff9a6a155d0b4f553a4864e2f4226 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Aug 2009 22:29:05 -0500 Subject: [PATCH 13/16] compiler.tree.propagation: remove method inlining heuristic --- .../tree/cleanup/cleanup-tests.factor | 10 +- .../call-effect/call-effect.factor | 2 +- .../tree/propagation/inlining/inlining.factor | 98 ++----------------- .../tree/propagation/propagation-tests.factor | 23 +++-- .../tree/propagation/propagation.factor | 2 - 5 files changed, 28 insertions(+), 107 deletions(-) diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 73ff49259a..faf6968670 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -41,13 +41,13 @@ IN: compiler.tree.cleanup.tests GENERIC: mynot ( x -- y ) -M: f mynot drop t ; +M: f mynot drop t ; inline -M: object mynot drop f ; +M: object mynot drop f ; inline GENERIC: detect-f ( x -- y ) -M: f detect-f ; +M: f detect-f ; inline [ t ] [ [ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined? @@ -55,9 +55,9 @@ M: f detect-f ; GENERIC: xyz ( n -- n ) -M: integer xyz ; +M: integer xyz ; inline -M: object xyz ; +M: object xyz ; inline [ t ] [ [ { integer } declare xyz ] \ xyz inlined? diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor index a667ea727f..cdbeabe532 100644 --- a/basis/compiler/tree/propagation/call-effect/call-effect.factor +++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor @@ -153,7 +153,7 @@ ERROR: uninferable ; : (value>quot) ( value-info -- quot ) dup class>> { - { \ quotation [ literal>> dup remember-inlining '[ drop @ ] ] } + { \ quotation [ literal>> dup add-to-history '[ drop @ ] ] } { \ curry [ slots>> third (value>quot) '[ [ obj>> ] [ quot>> @ ] bi ] diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 1586f2ca0b..3836e0f3ba 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -3,8 +3,8 @@ USING: accessors kernel arrays sequences math math.order math.partial-dispatch generic generic.standard generic.single generic.math classes.algebra classes.union sets quotations assocs combinators -words namespaces continuations classes fry combinators.smart hints -locals +combinators.short-circuit words namespaces continuations classes +fry hints locals compiler.tree compiler.tree.builder compiler.tree.recursive @@ -14,19 +14,6 @@ compiler.tree.propagation.info compiler.tree.propagation.nodes ; IN: compiler.tree.propagation.inlining -! We count nodes up-front; if there are relatively few nodes, -! we are more eager to inline -SYMBOL: node-count - -: count-nodes ( nodes -- n ) - 0 swap [ drop 1 + ] each-node ; - -: compute-node-count ( nodes -- ) count-nodes node-count set ; - -! We try not to inline the same word too many times, to avoid -! combinatorial explosion -SYMBOL: inlining-count - ! Splicing nodes : splicing-call ( #call word -- nodes ) [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; @@ -101,99 +88,28 @@ M: callable splicing-nodes splicing-body ; dupd inlining-math-partial eliminate-dispatch ; ! Method body inlining -SYMBOL: recursive-calls -DEFER: (flat-length) - -: word-flat-length ( word -- n ) - { - ! special-case - { [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] } - ! not inline - { [ dup inline? not ] [ drop 1 ] } - ! recursive and inline - { [ dup recursive-calls get key? ] [ drop 10 ] } - ! inline - [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ] - } cond ; - -: (flat-length) ( seq -- n ) - [ - { - { [ dup quotation? ] [ (flat-length) 2 + ] } - { [ dup array? ] [ (flat-length) ] } - { [ dup word? ] [ word-flat-length ] } - [ drop 0 ] - } cond - ] sigma ; - -: flat-length ( word -- n ) - H{ } clone recursive-calls [ - [ recursive-calls get conjoin ] - [ def>> (flat-length) 5 /i ] - bi - ] with-variable ; - -: classes-known? ( #call -- ? ) - in-d>> [ - value-info class>> - [ class-types length 1 = ] - [ union-class? not ] - bi and - ] any? ; - -: node-count-bias ( -- n ) - 45 node-count get [-] 8 /i ; - -: body-length-bias ( word -- n ) - [ flat-length ] [ inlining-count get at 0 or ] bi - over 2 <= [ drop ] [ 2/ 1 + * ] if 24 swap [-] 4 /i ; - -: inlining-rank ( #call word -- n ) - [ - [ classes-known? 2 0 ? ] - [ - [ body-length-bias ] - [ "specializer" word-prop 1 0 ? ] - [ method-body? 1 0 ? ] - tri - node-count-bias - loop-nesting get 0 or 2 * - ] bi* - ] sum-outputs ; - -: should-inline? ( #call word -- ? ) - dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ; - SYMBOL: history : already-inlined? ( obj -- ? ) history get memq? ; : add-to-history ( obj -- ) history [ swap suffix ] change ; -: remember-inlining ( word -- ) - [ inlining-count get inc-at ] - [ add-to-history ] - bi ; - :: inline-word ( #call word -- ? ) word already-inlined? [ f ] [ #call word splicing-body [ [ - word remember-inlining - [ ] [ count-nodes ] [ (propagate) ] tri + word add-to-history + dup (propagate) ] with-scope - [ #call (>>body) ] [ node-count +@ ] bi* t + #call (>>body) t ] [ f ] if* ] if ; -: inline-method-body ( #call word -- ? ) - 2dup should-inline? [ inline-word ] [ 2drop f ] if ; - : always-inline-word? ( word -- ? ) { curry compose } memq? ; : never-inline-word? ( word -- ? ) - [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ; + { [ deferred? ] [ "default" word-prop ] [ \ call eq? ] } 1|| ; : custom-inlining? ( word -- ? ) "custom-inlining" word-prop ; @@ -217,7 +133,7 @@ SYMBOL: history { [ dup always-inline-word? ] [ inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } - { [ dup method-body? ] [ inline-method-body ] } + { [ dup inline? ] [ inline-word ] } [ 2drop f ] } cond ; diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index eb9591c40c..1c9b27dfbc 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -56,9 +56,9 @@ IN: compiler.tree.propagation.tests [ float ] [ [ { float real } declare + ] final-math-class ] unit-test -[ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test +! [ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test -[ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test +! [ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test [ number ] [ [ { complex complex } declare + ] final-math-class ] unit-test @@ -444,6 +444,13 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; ] final-classes ] unit-test +[ V{ f { } } ] [ + [ + T{ mixed-mutable-immutable f 3 { } } + [ x>> ] [ y>> ] bi + ] final-literals +] unit-test + ! Recursive propagation : recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive @@ -502,8 +509,8 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; ] unit-test GENERIC: iterate ( obj -- next-obj ? ) -M: fixnum iterate f ; -M: array iterate first t ; +M: fixnum iterate f ; inline +M: array iterate first t ; inline : dead-loop ( obj -- final-obj ) iterate [ dead-loop ] when ; inline recursive @@ -567,7 +574,7 @@ M: array iterate first t ; ] unit-test GENERIC: bad-generic ( a -- b ) -M: fixnum bad-generic 1 fixnum+fast ; +M: fixnum bad-generic 1 fixnum+fast ; inline : bad-behavior ( -- b ) 4 bad-generic ; inline recursive [ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test @@ -740,7 +747,7 @@ TUPLE: foo bar ; [ t ] [ [ foo new ] { new } inlined? ] unit-test GENERIC: whatever ( x -- y ) -M: number whatever drop foo ; +M: number whatever drop foo ; inline [ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test @@ -749,8 +756,8 @@ M: number whatever drop foo ; [ f ] [ [ that-thing new ] { new } inlined? ] unit-test GENERIC: whatever2 ( x -- y ) -M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; -M: f whatever2 ; +M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; inline +M: f whatever2 ; inline [ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test [ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor index 3dd2c4998a..a11264fb7f 100644 --- a/basis/compiler/tree/propagation/propagation.factor +++ b/basis/compiler/tree/propagation/propagation.factor @@ -19,6 +19,4 @@ IN: compiler.tree.propagation H{ } clone copies set H{ } clone 1array value-infos set H{ } clone 1array constraints set - H{ } clone inlining-count set - dup compute-node-count dup (propagate) ; From bee6fa641e4df1aad62489b3e903d5b118785fa3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Aug 2009 22:32:21 -0500 Subject: [PATCH 14/16] Add inline declarations for various assorted methods --- basis/bit-arrays/bit-arrays.factor | 18 ++-- basis/grouping/grouping.factor | 20 ++-- basis/io/encodings/ascii/ascii.factor | 4 +- basis/math/bits/bits.factor | 4 +- basis/math/complex/complex.factor | 32 +++---- basis/math/functions/functions.factor | 22 ++--- basis/math/ranges/ranges.factor | 6 +- basis/math/ratios/ratios.factor | 4 +- .../known-words/known-words.factor | 2 + basis/tuple-arrays/tuple-arrays.factor | 10 +- basis/vectors/functor/functor.factor | 6 +- core/alien/alien.factor | 4 +- core/arrays/arrays.factor | 14 +-- core/assocs/assocs.factor | 34 +++---- core/byte-arrays/byte-arrays.factor | 12 +-- core/byte-vectors/byte-vectors.factor | 10 +- core/classes/builtin/builtin.factor | 4 +- core/classes/tuple/tuple.factor | 4 +- core/growable/growable.factor | 14 +-- core/hashtables/hashtables.factor | 10 +- core/io/encodings/utf8/utf8.factor | 2 +- core/kernel/kernel.factor | 12 +-- core/layouts/layouts.factor | 2 +- core/math/floats/floats.factor | 40 ++++---- core/math/integers/integers.factor | 94 +++++++++---------- core/math/math.factor | 30 +++--- core/math/order/order.factor | 20 ++-- core/sbufs/sbufs.factor | 12 +-- core/sequences/sequences.factor | 62 ++++++------ core/slots/slots.factor | 9 +- core/strings/strings.factor | 12 +-- core/vectors/vectors.factor | 8 +- core/words/words.factor | 4 +- 33 files changed, 268 insertions(+), 273 deletions(-) diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index 7aea3c458a..0b5a63a906 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -44,33 +44,33 @@ PRIVATE> : ( n -- bit-array ) dup bits>bytes bit-array boa ; inline -M: bit-array length length>> ; +M: bit-array length length>> ; inline M: bit-array nth-unsafe - [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; + [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline M: bit-array set-nth-unsafe [ >fixnum ] [ underlying>> ] bi* [ byte/bit set-bit ] 2keep - swap n>byte set-alien-unsigned-1 ; + swap n>byte set-alien-unsigned-1 ; inline GENERIC: clear-bits ( bit-array -- ) -M: bit-array clear-bits 0 (set-bits) ; +M: bit-array clear-bits 0 (set-bits) ; inline GENERIC: set-bits ( bit-array -- ) -M: bit-array set-bits -1 (set-bits) ; +M: bit-array set-bits -1 (set-bits) ; inline M: bit-array clone - [ length>> ] [ underlying>> clone ] bi bit-array boa ; + [ length>> ] [ underlying>> clone ] bi bit-array boa ; inline : >bit-array ( seq -- bit-array ) T{ bit-array f 0 B{ } } clone-like ; inline -M: bit-array like drop dup bit-array? [ >bit-array ] unless ; +M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline -M: bit-array new-sequence drop ; +M: bit-array new-sequence drop ; inline M: bit-array equal? over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ; @@ -81,7 +81,7 @@ M: bit-array resize resize-byte-array ] 2bi bit-array boa - dup clean-up ; + dup clean-up ; inline M: bit-array byte-length length 7 + -3 shift ; diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor index f68760a4e1..83579d2beb 100644 --- a/basis/grouping/grouping.factor +++ b/basis/grouping/grouping.factor @@ -18,41 +18,41 @@ GENERIC: group@ ( n groups -- from to seq ) M: chunking-seq set-nth group@ 0 swap copy ; -M: chunking-seq like drop { } like ; +M: chunking-seq like drop { } like ; inline INSTANCE: chunking-seq sequence MIXIN: subseq-chunking -M: subseq-chunking nth group@ subseq ; +M: subseq-chunking nth group@ subseq ; inline MIXIN: slice-chunking -M: slice-chunking nth group@ ; +M: slice-chunking nth group@ ; inline -M: slice-chunking nth-unsafe group@ slice boa ; +M: slice-chunking nth-unsafe group@ slice boa ; inline TUPLE: abstract-groups < chunking-seq ; M: abstract-groups length - [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; + [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; inline M: abstract-groups set-length - [ n>> * ] [ seq>> ] bi set-length ; + [ n>> * ] [ seq>> ] bi set-length ; inline M: abstract-groups group@ - [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; + [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; inline TUPLE: abstract-clumps < chunking-seq ; M: abstract-clumps length - [ seq>> length ] [ n>> ] bi - 1 + ; + [ seq>> length ] [ n>> ] bi - 1 + ; inline M: abstract-clumps set-length - [ n>> + 1 - ] [ seq>> ] bi set-length ; + [ n>> + 1 - ] [ seq>> ] bi set-length ; inline M: abstract-clumps group@ - [ n>> over + ] [ seq>> ] bi ; + [ n>> over + ] [ seq>> ] bi ; inline PRIVATE> diff --git a/basis/io/encodings/ascii/ascii.factor b/basis/io/encodings/ascii/ascii.factor index 16132ca810..00d3bc7509 100644 --- a/basis/io/encodings/ascii/ascii.factor +++ b/basis/io/encodings/ascii/ascii.factor @@ -16,7 +16,7 @@ PRIVATE> SINGLETON: ascii M: ascii encode-char - 128 encode-if< ; + 128 encode-if< ; inline M: ascii decode-char - 128 decode-if< ; + 128 decode-if< ; inline diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor index e469140ff4..4de49c06a7 100644 --- a/basis/math/bits/bits.factor +++ b/basis/math/bits/bits.factor @@ -9,9 +9,9 @@ C: bits : make-bits ( number -- bits ) [ T{ bits f 0 0 } ] [ dup abs log2 1 + ] if-zero ; inline -M: bits length length>> ; +M: bits length length>> ; inline -M: bits nth-unsafe number>> swap bit? ; +M: bits nth-unsafe number>> swap bit? ; inline INSTANCE: bits immutable-sequence diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor index 832a9e64ba..ce94dfaca8 100644 --- a/basis/math/complex/complex.factor +++ b/basis/math/complex/complex.factor @@ -5,29 +5,29 @@ math.libm math.functions arrays math.functions.private sequences parser ; IN: math.complex.private -M: real real-part ; -M: real imaginary-part drop 0 ; -M: complex real-part real>> ; -M: complex imaginary-part imaginary>> ; -M: complex absq >rect [ sq ] bi@ + ; -M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ; +M: real real-part ; inline +M: real imaginary-part drop 0 ; inline +M: complex real-part real>> ; inline +M: complex imaginary-part imaginary>> ; inline +M: complex absq >rect [ sq ] bi@ + ; inline +M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ; inline : componentwise ( x y quot -- a b ) [ [ >rect ] bi@ ] dip bi-curry@ bi* ; inline : complex= ( x y quot -- ? ) componentwise and ; inline -M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ; -M: complex number= [ number= ] complex= ; +M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ; inline +M: complex number= [ number= ] complex= ; inline : complex-op ( x y quot -- z ) componentwise rect> ; inline -M: complex + [ + ] complex-op ; -M: complex - [ - ] complex-op ; +M: complex + [ + ] complex-op ; inline +M: complex - [ - ] complex-op ; inline : *re ( x y -- xr*yr xi*yi ) [ >rect ] bi@ [ * ] bi-curry@ bi* ; inline : *im ( x y -- xi*yr xr*yi ) swap [ >rect ] bi@ swap [ * ] bi-curry@ bi* ; inline -M: complex * [ *re - ] [ *im + ] 2bi rect> ; +M: complex * [ *re - ] [ *im + ] 2bi rect> ; inline : (complex/) ( x y -- r i m ) [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline : complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ rect> ; inline -M: complex / [ / ] complex/ ; -M: complex /f [ /f ] complex/ ; -M: complex /i [ /i ] complex/ ; -M: complex abs absq >float fsqrt ; -M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; +M: complex / [ / ] complex/ ; inline +M: complex /f [ /f ] complex/ ; inline +M: complex /i [ /i ] complex/ ; inline +M: complex abs absq >float fsqrt ; inline +M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; inline IN: syntax diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 801522b376..0daea7f706 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -13,7 +13,7 @@ IN: math.functions GENERIC: sqrt ( x -- y ) foldable M: real sqrt - >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; + >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; inline : factor-2s ( n -- r s ) #! factor an integer into 2^r * s @@ -120,7 +120,7 @@ ERROR: non-trivial-divisor n ; GENERIC: absq ( x -- y ) foldable -M: real absq sq ; +M: real absq sq ; inline : ~abs ( x y epsilon -- ? ) [ - abs ] dip < ; @@ -148,13 +148,13 @@ M: real absq sq ; GENERIC: exp ( x -- y ) -M: real exp fexp ; +M: real exp fexp ; inline M: complex exp >rect swap fexp swap polar> ; GENERIC: log ( x -- y ) -M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; +M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline M: complex log >polar swap flog swap rect> ; @@ -169,7 +169,7 @@ M: complex cos [ [ fcos ] [ fcosh ] bi* * ] [ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ; -M: real cos fcos ; +M: real cos fcos ; inline : sec ( x -- y ) cos recip ; inline @@ -180,7 +180,7 @@ M: complex cosh [ [ fcosh ] [ fcos ] bi* * ] [ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ; -M: real cosh fcosh ; +M: real cosh fcosh ; inline : sech ( x -- y ) cosh recip ; inline @@ -191,7 +191,7 @@ M: complex sin [ [ fsin ] [ fcosh ] bi* * ] [ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ; -M: real sin fsin ; +M: real sin fsin ; inline : cosec ( x -- y ) sin recip ; inline @@ -202,7 +202,7 @@ M: complex sinh [ [ fsinh ] [ fcos ] bi* * ] [ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ; -M: real sinh fsinh ; +M: real sinh fsinh ; inline : cosech ( x -- y ) sinh recip ; inline @@ -210,13 +210,13 @@ GENERIC: tan ( x -- y ) foldable M: complex tan [ sin ] [ cos ] bi / ; -M: real tan ftan ; +M: real tan ftan ; inline GENERIC: tanh ( x -- y ) foldable M: complex tanh [ sinh ] [ cosh ] bi / ; -M: real tanh ftanh ; +M: real tanh ftanh ; inline : cot ( x -- y ) tan recip ; inline @@ -252,7 +252,7 @@ GENERIC: atan ( x -- y ) foldable M: complex atan i* atanh i* ; -M: real atan fatan ; +M: real atan fatan ; inline : asec ( x -- y ) recip acos ; inline diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index d28afa1413..58cb2b09db 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -12,11 +12,9 @@ TUPLE: range : ( a b step -- range ) [ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline -M: range length ( seq -- n ) - length>> ; +M: range length ( seq -- n ) length>> ; inline -M: range nth-unsafe ( n range -- obj ) - [ step>> * ] keep from>> + ; +M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; inline ! For ranges with many elements, the default element-wise methods ! sequences define are unsuitable because they're O(n) diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index 7da92cd154..dcb8e87e7c 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -48,8 +48,8 @@ M: ratio >fixnum >fraction /i >fixnum ; M: ratio >bignum >fraction /i >bignum ; M: ratio >float >fraction /f ; -M: ratio numerator numerator>> ; -M: ratio denominator denominator>> ; +M: ratio numerator numerator>> ; inline +M: ratio denominator denominator>> ; inline M: ratio < scale < ; M: ratio <= scale <= ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 0edbe5e53d..ea8f6f5f49 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -158,6 +158,8 @@ M: bad-executable summary \ [ infer- ] "special" set-word-prop +\ t "flushable" set-word-prop + : infer-effect-unsafe ( word -- ) pop-literal nip add-effect-input diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index 761dbd816a..92e7541616 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -54,17 +54,17 @@ TUPLE: CLASS-array [ \ CLASS [ tuple-prototype concat ] [ tuple-arity ] bi ] keep \ CLASS-array boa ; inline -M: CLASS-array length length>> ; +M: CLASS-array length length>> ; inline -M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; +M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; inline -M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; +M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; inline -M: CLASS-array new-sequence drop ; +M: CLASS-array new-sequence drop ; inline : >CLASS-array ( seq -- tuple-array ) 0 clone-like ; -M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; +M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; inline INSTANCE: CLASS-array sequence diff --git a/basis/vectors/functor/functor.factor b/basis/vectors/functor/functor.factor index 47a6c2090a..b70c7c5050 100644 --- a/basis/vectors/functor/functor.factor +++ b/basis/vectors/functor/functor.factor @@ -18,11 +18,11 @@ TUPLE: V { underlying A } { length array-capacity } ; M: V like drop dup V instance? [ dup A instance? [ dup length V boa ] [ >V ] if - ] unless ; + ] unless ; inline -M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; +M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; inline -M: A new-resizable drop ; +M: A new-resizable drop ; inline M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; diff --git a/core/alien/alien.factor b/core/alien/alien.factor index ec38e3be5b..d98ea3d103 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -20,11 +20,11 @@ UNION: pinned-c-ptr GENERIC: >c-ptr ( obj -- c-ptr ) -M: c-ptr >c-ptr ; +M: c-ptr >c-ptr ; inline SLOT: underlying -M: object >c-ptr underlying>> ; +M: object >c-ptr underlying>> ; inline GENERIC: expired? ( c-ptr -- ? ) flushable diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index dd70e45b6b..fa4d4b2f69 100644 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -4,17 +4,17 @@ USING: accessors kernel kernel.private math math.private sequences sequences.private ; IN: arrays -M: array clone (clone) ; -M: array length length>> ; -M: array nth-unsafe [ >fixnum ] dip array-nth ; -M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; -M: array resize resize-array ; +M: array clone (clone) ; inline +M: array length length>> ; inline +M: array nth-unsafe [ >fixnum ] dip array-nth ; inline +M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; inline +M: array resize resize-array ; inline : >array ( seq -- array ) { } clone-like ; -M: object new-sequence drop 0 ; +M: object new-sequence drop 0 ; inline -M: f new-sequence drop [ f ] [ 0 ] if-zero ; +M: f new-sequence drop [ f ] [ 0 ] if-zero ; inline M: array equal? over array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 8b6809236c..e633a54843 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -17,7 +17,7 @@ GENERIC: assoc-like ( assoc exemplar -- newassoc ) GENERIC: assoc-clone-like ( assoc exemplar -- newassoc ) GENERIC: >alist ( assoc -- newassoc ) -M: assoc assoc-like drop ; +M: assoc assoc-like drop ; inline : ?at ( key assoc -- value/key ? ) 2dup at* [ 2nip t ] [ 2drop f ] if ; inline @@ -87,7 +87,7 @@ PRIVATE> M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) [ dup assoc-size ] dip new-assoc - [ [ set-at ] with-assoc assoc-each ] keep ; + [ [ set-at ] with-assoc assoc-each ] keep ; inline : keys ( assoc -- keys ) [ drop ] { } assoc>map ; @@ -189,48 +189,48 @@ M: sequence set-at [ 2nip set-second ] [ drop [ swap 2array ] dip push ] if ; -M: sequence new-assoc drop ; +M: sequence new-assoc drop ; inline -M: sequence clear-assoc delete-all ; +M: sequence clear-assoc delete-all ; inline M: sequence delete-at [ nip ] [ search-alist nip ] 2bi [ swap delete-nth ] [ drop ] if* ; -M: sequence assoc-size length ; +M: sequence assoc-size length ; inline M: sequence assoc-clone-like - [ >alist ] dip clone-like ; + [ >alist ] dip clone-like ; inline M: sequence assoc-like - [ >alist ] dip like ; + [ >alist ] dip like ; inline -M: sequence >alist ; +M: sequence >alist ; inline ! Override sequence => assoc instance for f -M: f clear-assoc drop ; +M: f clear-assoc drop ; inline -M: f assoc-like drop dup assoc-empty? [ drop f ] when ; +M: f assoc-like drop dup assoc-empty? [ drop f ] when ; inline INSTANCE: sequence assoc -TUPLE: enum seq ; +TUPLE: enum { seq read-only } ; C: enum M: enum at* seq>> 2dup bounds-check? - [ nth t ] [ 2drop f f ] if ; + [ nth t ] [ 2drop f f ] if ; inline -M: enum set-at seq>> set-nth ; +M: enum set-at seq>> set-nth ; inline -M: enum delete-at seq>> delete-nth ; +M: enum delete-at seq>> delete-nth ; inline M: enum >alist ( enum -- alist ) - seq>> [ length ] keep zip ; + seq>> [ length ] keep zip ; inline -M: enum assoc-size seq>> length ; +M: enum assoc-size seq>> length ; inline -M: enum clear-assoc seq>> delete-all ; +M: enum clear-assoc seq>> delete-all ; inline INSTANCE: enum assoc diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index 72989ac447..3c89a5f63e 100644 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -4,18 +4,18 @@ USING: accessors kernel kernel.private alien.accessors sequences sequences.private math ; IN: byte-arrays -M: byte-array clone (clone) ; -M: byte-array length length>> ; -M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; -M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; +M: byte-array clone (clone) ; inline +M: byte-array length length>> ; inline +M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; inline +M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; inline : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline -M: byte-array new-sequence drop (byte-array) ; +M: byte-array new-sequence drop (byte-array) ; inline M: byte-array equal? over byte-array? [ sequence= ] [ 2drop f ] if ; M: byte-array resize - resize-byte-array ; + resize-byte-array ; inline INSTANCE: byte-array sequence diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index fc3d9501c7..287e972405 100644 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -18,15 +18,15 @@ M: byte-vector like drop dup byte-vector? [ dup byte-array? [ dup length byte-vector boa ] [ >byte-vector ] if - ] unless ; + ] unless ; inline M: byte-vector new-sequence - drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ; + drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ; inline M: byte-vector equal? over byte-vector? [ sequence= ] [ 2drop f ] if ; -M: byte-vector contract 2drop ; +M: byte-vector contract 2drop ; inline M: byte-array like #! If we have an byte-array, we're done. @@ -39,8 +39,8 @@ M: byte-array like 2dup length eq? [ nip ] [ resize-byte-array ] if ] [ >byte-array ] if - ] unless ; + ] unless ; inline -M: byte-array new-resizable drop ; +M: byte-array new-resizable drop ; inline INSTANCE: byte-vector growable diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index c74c8f3b50..8eeb4ce357 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -20,9 +20,9 @@ PREDICATE: hi-tag-class < builtin-class class>type 7 > ; : bootstrap-type>class ( n -- class ) builtins get nth ; -M: hi-tag class hi-tag type>class ; +M: hi-tag class hi-tag type>class ; inline -M: object class tag type>class ; +M: object class tag type>class ; inline M: builtin-class rank-class drop 0 ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 8e49e2f5f4..0a437a3d69 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -29,7 +29,7 @@ PREDICATE: immutable-tuple-class < tuple-class ( class -- ? ) : layout-of ( tuple -- layout ) 1 slot { array } declare ; inline -M: tuple class layout-of 2 slot { word } declare ; +M: tuple class layout-of 2 slot { word } declare ; inline : tuple-size ( tuple -- size ) layout-of 3 slot { fixnum } declare ; inline @@ -323,7 +323,7 @@ M: tuple-class (classes-intersect?) [ swap classes-intersect? ] } cond ; -M: tuple clone (clone) ; +M: tuple clone (clone) ; inline M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ; diff --git a/core/growable/growable.factor b/core/growable/growable.factor index 754a3293d1..68a8de3d43 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -9,9 +9,9 @@ MIXIN: growable SLOT: length SLOT: underlying -M: growable length length>> ; -M: growable nth-unsafe underlying>> nth-unsafe ; -M: growable set-nth-unsafe underlying>> set-nth-unsafe ; +M: growable length length>> ; inline +M: growable nth-unsafe underlying>> nth-unsafe ; inline +M: growable set-nth-unsafe underlying>> set-nth-unsafe ; inline : capacity ( seq -- n ) underlying>> length ; inline @@ -49,21 +49,21 @@ M: growable set-length ( n seq -- ) [ >fixnum ] dip ] if ; inline -M: growable set-nth ensure set-nth-unsafe ; +M: growable set-nth ensure set-nth-unsafe ; inline -M: growable clone (clone) [ clone ] change-underlying ; +M: growable clone (clone) [ clone ] change-underlying ; inline M: growable lengthen ( n seq -- ) 2dup length > [ 2dup capacity > [ over new-size over expand ] when 2dup (>>length) - ] when 2drop ; + ] when 2drop ; inline M: growable shorten ( n seq -- ) growable-check 2dup length < [ 2dup contract 2dup (>>length) - ] when 2drop ; + ] when 2drop ; inline INSTANCE: growable sequence diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 03bc3e01fd..8547f53a0e 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -112,7 +112,7 @@ M: hashtable delete-at ( key hash -- ) ] if ; M: hashtable assoc-size ( hash -- n ) - [ count>> ] [ deleted>> ] bi - ; + [ count>> ] [ deleted>> ] bi - ; inline : rehash ( hash -- ) dup >alist [ @@ -150,7 +150,7 @@ M: hashtable >alist ] keep { } like ; M: hashtable clone - (clone) [ clone ] change-array ; + (clone) [ clone ] change-array ; inline M: hashtable equal? over hashtable? [ @@ -159,15 +159,15 @@ M: hashtable equal? ] [ 2drop f ] if ; ! Default method -M: assoc new-assoc drop ; +M: assoc new-assoc drop ; inline -M: f new-assoc drop ; +M: f new-assoc drop ; inline : >hashtable ( assoc -- hashtable ) H{ } assoc-clone-like ; M: hashtable assoc-like - drop dup hashtable? [ >hashtable ] unless ; + drop dup hashtable? [ >hashtable ] unless ; inline : ?set-at ( value key assoc/f -- assoc ) [ [ set-at ] keep ] [ associate ] if* ; diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index a722655cad..2911385c09 100755 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -40,7 +40,7 @@ SINGLETON: utf8 dup stream-read1 dup [ begin-utf8 ] when nip ; inline M: utf8 decode-char - drop decode-utf8 ; + drop decode-utf8 ; inline ! Encoding UTF-8 diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index d6350e0420..838d877a40 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -192,19 +192,19 @@ UNION: boolean POSTPONE: t POSTPONE: f ; ! Object protocol GENERIC: hashcode* ( depth obj -- code ) -M: object hashcode* 2drop 0 ; +M: object hashcode* 2drop 0 ; inline -M: f hashcode* 2drop 31337 ; +M: f hashcode* 2drop 31337 ; inline : hashcode ( obj -- code ) 3 swap hashcode* ; inline GENERIC: equal? ( obj1 obj2 -- ? ) -M: object equal? 2drop f ; +M: object equal? 2drop f ; inline TUPLE: identity-tuple ; -M: identity-tuple equal? 2drop f ; +M: identity-tuple equal? 2drop f ; inline : = ( obj1 obj2 -- ? ) 2dup eq? [ 2drop t ] [ @@ -213,9 +213,9 @@ M: identity-tuple equal? 2drop f ; GENERIC: clone ( obj -- cloned ) -M: object clone ; +M: object clone ; inline -M: callstack clone (clone) ; +M: callstack clone (clone) ; inline ! Tuple construction GENERIC: new ( class -- tuple ) diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index 42898fc085..5738c2ec99 100644 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -78,6 +78,6 @@ M: bignum >integer M: real >integer dup most-negative-fixnum most-positive-fixnum between? - [ >fixnum ] [ >bignum ] if ; + [ >fixnum ] [ >bignum ] if ; inline UNION: immediate fixnum POSTPONE: f ; diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 2a22dc4330..160b220173 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -3,28 +3,28 @@ USING: kernel math math.private ; IN: math.floats.private -M: fixnum >float fixnum>float ; -M: bignum >float bignum>float ; +M: fixnum >float fixnum>float ; inline +M: bignum >float bignum>float ; inline -M: float >fixnum float>fixnum ; -M: float >bignum float>bignum ; -M: float >float ; +M: float >fixnum float>fixnum ; inline +M: float >bignum float>bignum ; inline +M: float >float ; inline -M: float hashcode* nip float>bits ; -M: float equal? over float? [ float= ] [ 2drop f ] if ; -M: float number= float= ; +M: float hashcode* nip float>bits ; inline +M: float equal? over float? [ float= ] [ 2drop f ] if ; inline +M: float number= float= ; inline -M: float < float< ; -M: float <= float<= ; -M: float > float> ; -M: float >= float>= ; +M: float < float< ; inline +M: float <= float<= ; inline +M: float > float> ; inline +M: float >= float>= ; inline -M: float + float+ ; -M: float - float- ; -M: float * float* ; -M: float / float/f ; -M: float /f float/f ; -M: float /i float/f >integer ; -M: float mod float-mod ; +M: float + float+ ; inline +M: float - float- ; inline +M: float * float* ; inline +M: float / float/f ; inline +M: float /f float/f ; inline +M: float /i float/f >integer ; inline +M: float mod float-mod ; inline -M: real abs dup 0 < [ neg ] when ; +M: real abs dup 0 < [ neg ] when ; inline diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 2b35ef76fd..75abd8087e 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -5,79 +5,79 @@ USING: kernel kernel.private sequences sequences.private math math.private combinators ; IN: math.integers.private -M: integer numerator ; -M: integer denominator drop 1 ; +M: integer numerator ; inline +M: integer denominator drop 1 ; inline -M: fixnum >fixnum ; -M: fixnum >bignum fixnum>bignum ; -M: fixnum >integer ; +M: fixnum >fixnum ; inline +M: fixnum >bignum fixnum>bignum ; inline +M: fixnum >integer ; inline -M: fixnum hashcode* nip ; -M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; -M: fixnum number= eq? ; +M: fixnum hashcode* nip ; inline +M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; inline +M: fixnum number= eq? ; inline -M: fixnum < fixnum< ; -M: fixnum <= fixnum<= ; -M: fixnum > fixnum> ; -M: fixnum >= fixnum>= ; +M: fixnum < fixnum< ; inline +M: fixnum <= fixnum<= ; inline +M: fixnum > fixnum> ; inline +M: fixnum >= fixnum>= ; inline -M: fixnum + fixnum+ ; -M: fixnum - fixnum- ; -M: fixnum * fixnum* ; -M: fixnum /i fixnum/i ; -M: fixnum /f [ >float ] dip >float float/f ; +M: fixnum + fixnum+ ; inline +M: fixnum - fixnum- ; inline +M: fixnum * fixnum* ; inline +M: fixnum /i fixnum/i ; inline +M: fixnum /f [ >float ] dip >float float/f ; inline -M: fixnum mod fixnum-mod ; +M: fixnum mod fixnum-mod ; inline -M: fixnum /mod fixnum/mod ; +M: fixnum /mod fixnum/mod ; inline -M: fixnum bitand fixnum-bitand ; -M: fixnum bitor fixnum-bitor ; -M: fixnum bitxor fixnum-bitxor ; -M: fixnum shift >fixnum fixnum-shift ; +M: fixnum bitand fixnum-bitand ; inline +M: fixnum bitor fixnum-bitor ; inline +M: fixnum bitxor fixnum-bitxor ; inline +M: fixnum shift >fixnum fixnum-shift ; inline -M: fixnum bitnot fixnum-bitnot ; +M: fixnum bitnot fixnum-bitnot ; inline -M: fixnum bit? neg shift 1 bitand 0 > ; +M: fixnum bit? neg shift 1 bitand 0 > ; inline : fixnum-log2 ( x -- n ) 0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ; -M: fixnum (log2) fixnum-log2 ; +M: fixnum (log2) fixnum-log2 ; inline -M: bignum >fixnum bignum>fixnum ; -M: bignum >bignum ; +M: bignum >fixnum bignum>fixnum ; inline +M: bignum >bignum ; inline M: bignum hashcode* nip >fixnum ; M: bignum equal? over bignum? [ bignum= ] [ swap dup fixnum? [ >bignum bignum= ] [ 2drop f ] if - ] if ; + ] if ; inline -M: bignum number= bignum= ; +M: bignum number= bignum= ; inline -M: bignum < bignum< ; -M: bignum <= bignum<= ; -M: bignum > bignum> ; -M: bignum >= bignum>= ; +M: bignum < bignum< ; inline +M: bignum <= bignum<= ; inline +M: bignum > bignum> ; inline +M: bignum >= bignum>= ; inline -M: bignum + bignum+ ; -M: bignum - bignum- ; -M: bignum * bignum* ; -M: bignum /i bignum/i ; -M: bignum mod bignum-mod ; +M: bignum + bignum+ ; inline +M: bignum - bignum- ; inline +M: bignum * bignum* ; inline +M: bignum /i bignum/i ; inline +M: bignum mod bignum-mod ; inline -M: bignum /mod bignum/mod ; +M: bignum /mod bignum/mod ; inline -M: bignum bitand bignum-bitand ; -M: bignum bitor bignum-bitor ; -M: bignum bitxor bignum-bitxor ; -M: bignum shift >fixnum bignum-shift ; +M: bignum bitand bignum-bitand ; inline +M: bignum bitor bignum-bitor ; inline +M: bignum bitxor bignum-bitxor ; inline +M: bignum shift >fixnum bignum-shift ; inline -M: bignum bitnot bignum-bitnot ; -M: bignum bit? bignum-bit? ; -M: bignum (log2) bignum-log2 ; +M: bignum bitnot bignum-bitnot ; inline +M: bignum bit? bignum-bit? ; inline +M: bignum (log2) bignum-log2 ; inline ! Converting ratios to floats. Based on FLOAT-RATIO from ! sbcl/src/code/float.lisp, which has the following license: diff --git a/core/math/math.factor b/core/math/math.factor index a00f2240e1..1213e13a1f 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -98,38 +98,38 @@ GENERIC: fp-infinity? ( x -- ? ) GENERIC: fp-nan-payload ( x -- bits ) M: object fp-special? - drop f ; + drop f ; inline M: object fp-nan? - drop f ; + drop f ; inline M: object fp-qnan? - drop f ; + drop f ; inline M: object fp-snan? - drop f ; + drop f ; inline M: object fp-infinity? - drop f ; + drop f ; inline M: object fp-nan-payload - drop f ; + drop f ; inline M: float fp-special? - double>bits -52 shift HEX: 7ff [ bitand ] keep = ; + double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline M: float fp-nan-payload - double>bits HEX: fffffffffffff bitand ; foldable flushable + double>bits HEX: fffffffffffff bitand ; inline M: float fp-nan? - dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; + dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline M: float fp-qnan? - dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ; + dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ; inline M: float fp-snan? - dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ; + dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ; inline M: float fp-infinity? - dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; + dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline : ( payload -- nan ) - HEX: 7ff0000000000000 bitor bits>double ; foldable flushable + HEX: 7ff0000000000000 bitor bits>double ; inline : next-float ( m -- n ) double>bits @@ -137,7 +137,7 @@ M: float fp-infinity? dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero 1 + bits>double ! positive ] if - ] if ; foldable flushable + ] if ; inline : prev-float ( m -- n ) double>bits @@ -145,7 +145,7 @@ M: float fp-infinity? dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero 1 - bits>double ! positive non-zero ] if - ] if ; foldable flushable + ] if ; inline : next-power-of-2 ( m -- n ) dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline diff --git a/core/math/order/order.factor b/core/math/order/order.factor index 435eec9b96..707dc02af2 100644 --- a/core/math/order/order.factor +++ b/core/math/order/order.factor @@ -15,24 +15,24 @@ GENERIC: <=> ( obj1 obj2 -- <=> ) : >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline -M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; +M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline GENERIC: before? ( obj1 obj2 -- ? ) GENERIC: after? ( obj1 obj2 -- ? ) GENERIC: before=? ( obj1 obj2 -- ? ) GENERIC: after=? ( obj1 obj2 -- ? ) -M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; -M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; -M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; -M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; +M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; inline +M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; inline +M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; inline +M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; inline -M: real before? ( obj1 obj2 -- ? ) < ; -M: real after? ( obj1 obj2 -- ? ) > ; -M: real before=? ( obj1 obj2 -- ? ) <= ; -M: real after=? ( obj1 obj2 -- ? ) >= ; +M: real before? ( obj1 obj2 -- ? ) < ; inline +M: real after? ( obj1 obj2 -- ? ) > ; inline +M: real before=? ( obj1 obj2 -- ? ) <= ; inline +M: real after=? ( obj1 obj2 -- ? ) >= ; inline -: min ( x y -- z ) [ before? ] most ; inline +: min ( x y -- z ) [ before? ] most ; inline : max ( x y -- z ) [ after? ] most ; inline : clamp ( x min max -- y ) [ max ] dip min ; inline diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor index 0b2c170c1e..49b6ec1374 100644 --- a/core/sbufs/sbufs.factor +++ b/core/sbufs/sbufs.factor @@ -11,24 +11,24 @@ TUPLE: sbuf : ( n -- sbuf ) 0 0 sbuf boa ; inline M: sbuf set-nth-unsafe - [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ; + [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ; inline M: sbuf new-sequence - drop [ 0 ] [ >fixnum ] bi sbuf boa ; + drop [ 0 ] [ >fixnum ] bi sbuf boa ; inline : >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline M: sbuf like drop dup sbuf? [ dup string? [ dup length sbuf boa ] [ >sbuf ] if - ] unless ; + ] unless ; inline -M: sbuf new-resizable drop ; +M: sbuf new-resizable drop ; inline M: sbuf equal? over sbuf? [ sequence= ] [ 2drop f ] if ; -M: string new-resizable drop ; +M: string new-resizable drop ; inline M: string like #! If we have a string, we're done. @@ -41,6 +41,6 @@ M: string like 2dup length eq? [ nip dup reset-string-hashcode ] [ resize-string ] if ] [ >string ] if - ] unless ; + ] unless ; inline INSTANCE: sbuf growable diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 84b80794a3..031d5f7b4a 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -18,14 +18,14 @@ GENERIC: clone-like ( seq exemplar -- newseq ) flushable : new-like ( len exemplar quot -- seq ) over [ [ new-sequence ] dip call ] dip like ; inline -M: sequence like drop ; +M: sequence like drop ; inline GENERIC: lengthen ( n seq -- ) GENERIC: shorten ( n seq -- ) -M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; +M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; inline -M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; +M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline : empty? ( seq -- ? ) length 0 = ; inline @@ -82,25 +82,25 @@ GENERIC: resize ( n seq -- newseq ) flushable GENERIC: nth-unsafe ( n seq -- elt ) flushable GENERIC: set-nth-unsafe ( elt n seq -- ) -M: sequence nth bounds-check nth-unsafe ; -M: sequence set-nth bounds-check set-nth-unsafe ; +M: sequence nth bounds-check nth-unsafe ; inline +M: sequence set-nth bounds-check set-nth-unsafe ; inline -M: sequence nth-unsafe nth ; -M: sequence set-nth-unsafe set-nth ; +M: sequence nth-unsafe nth ; inline +M: sequence set-nth-unsafe set-nth ; inline : change-nth-unsafe ( i seq quot -- ) [ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline ! The f object supports the sequence protocol trivially -M: f length drop 0 ; -M: f nth-unsafe nip ; -M: f like drop [ f ] when-empty ; +M: f length drop 0 ; inline +M: f nth-unsafe nip ; inline +M: f like drop [ f ] when-empty ; inline INSTANCE: f immutable-sequence ! Integers support the sequence protocol -M: integer length ; -M: integer nth-unsafe drop ; +M: integer length ; inline +M: integer nth-unsafe drop ; inline INSTANCE: integer immutable-sequence @@ -113,8 +113,8 @@ TUPLE: iota { n integer read-only } ; > ; -M: iota nth-unsafe drop ; +M: iota length n>> ; inline +M: iota nth-unsafe drop ; inline INSTANCE: iota immutable-sequence @@ -185,12 +185,12 @@ MIXIN: virtual-sequence GENERIC: virtual-seq ( seq -- seq' ) GENERIC: virtual@ ( n seq -- n' seq' ) -M: virtual-sequence nth virtual@ nth ; -M: virtual-sequence set-nth virtual@ set-nth ; -M: virtual-sequence nth-unsafe virtual@ nth-unsafe ; -M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ; -M: virtual-sequence like virtual-seq like ; -M: virtual-sequence new-sequence virtual-seq new-sequence ; +M: virtual-sequence nth virtual@ nth ; inline +M: virtual-sequence set-nth virtual@ set-nth ; inline +M: virtual-sequence nth-unsafe virtual@ nth-unsafe ; inline +M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ; inline +M: virtual-sequence like virtual-seq like ; inline +M: virtual-sequence new-sequence virtual-seq new-sequence ; inline INSTANCE: virtual-sequence sequence @@ -199,11 +199,9 @@ TUPLE: reversed { seq read-only } ; C: reversed -M: reversed virtual-seq seq>> ; - -M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; - -M: reversed length seq>> length ; +M: reversed virtual-seq seq>> ; inline +M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; inline +M: reversed length seq>> length ; inline INSTANCE: reversed virtual-sequence @@ -233,11 +231,11 @@ TUPLE: slice-error from to seq reason ; check-slice slice boa ; inline -M: slice virtual-seq seq>> ; +M: slice virtual-seq seq>> ; inline -M: slice virtual@ [ from>> + ] [ seq>> ] bi ; +M: slice virtual@ [ from>> + ] [ seq>> ] bi ; inline -M: slice length [ to>> ] [ from>> ] bi - ; +M: slice length [ to>> ] [ from>> ] bi - ; inline : short ( seq n -- seq n' ) over length min ; inline @@ -260,8 +258,8 @@ TUPLE: repetition { len read-only } { elt read-only } ; C: repetition -M: repetition length len>> ; -M: repetition nth-unsafe nip elt>> ; +M: repetition length len>> ; inline +M: repetition nth-unsafe nip elt>> ; inline INSTANCE: repetition immutable-sequence @@ -316,9 +314,9 @@ PRIVATE> (copy) drop ; inline M: sequence clone-like - [ dup length ] dip new-sequence [ 0 swap copy ] keep ; + [ dup length ] dip new-sequence [ 0 swap copy ] keep ; inline -M: immutable-sequence clone-like like ; +M: immutable-sequence clone-like like ; inline : push-all ( src dest -- ) [ length ] [ copy ] bi ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 9215857018..e2d75d6362 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -24,7 +24,8 @@ PREDICATE: writer-method < method-body "writing" word-prop ; [ create-method ] 2dip [ [ props>> ] [ drop ] [ ] tri* update ] [ drop define ] - 3bi ; + [ 2drop make-inline ] + 3tri ; GENERIC# reader-quot 1 ( class slot-spec -- quot ) @@ -41,11 +42,7 @@ M: object reader-quot dup t "reader" set-word-prop ; : reader-props ( slot-spec -- assoc ) - [ - [ "reading" set ] - [ read-only>> [ t "foldable" set ] when ] bi - t "flushable" set - ] H{ } make-assoc ; + "reading" associate ; : define-reader-generic ( name -- ) reader-word (( object -- value )) define-simple-generic ; diff --git a/core/strings/strings.factor b/core/strings/strings.factor index ffcefab78b..8ab0409318 100644 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -37,24 +37,24 @@ M: string hashcode* [ ] [ dup rehash-string string-hashcode ] ?if ; M: string length - length>> ; + length>> ; inline M: string nth-unsafe - [ >fixnum ] dip string-nth ; + [ >fixnum ] dip string-nth ; inline M: string set-nth-unsafe dup reset-string-hashcode - [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ; + [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ; inline M: string clone - (clone) [ clone ] change-aux ; + (clone) [ clone ] change-aux ; inline -M: string resize resize-string ; +M: string resize resize-string ; inline : 1string ( ch -- str ) 1 swap ; : >string ( seq -- str ) "" clone-like ; -M: string new-sequence drop 0 ; +M: string new-sequence drop 0 ; inline INSTANCE: string sequence diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor index 1bdda7b69d..4bbc787294 100644 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -15,10 +15,10 @@ TUPLE: vector M: vector like drop dup vector? [ dup array? [ dup length vector boa ] [ >vector ] if - ] unless ; + ] unless ; inline M: vector new-sequence - drop [ f ] [ >fixnum ] bi vector boa ; + drop [ f ] [ >fixnum ] bi vector boa ; inline M: vector equal? over vector? [ sequence= ] [ 2drop f ] if ; @@ -34,9 +34,9 @@ M: array like 2dup length eq? [ nip ] [ resize-array ] if ] [ >array ] if - ] unless ; + ] unless ; inline -M: sequence new-resizable drop ; +M: sequence new-resizable drop ; inline INSTANCE: vector growable diff --git a/core/words/words.factor b/core/words/words.factor index 2ebdb8b7a8..19a2ce551d 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -12,7 +12,7 @@ IN: words M: word execute (execute) ; -M: word ?execute execute( -- value ) ; +M: word ?execute execute( -- value ) ; inline M: word <=> [ [ name>> ] [ vocabulary>> ] bi 2array ] compare ; @@ -213,7 +213,7 @@ M: word forget* ] if ; M: word hashcode* - nip 1 slot { fixnum } declare ; foldable + nip 1 slot { fixnum } declare ; inline foldable M: word literalize ; From 66afcff1e0b3e98e2e3c4351a31ca3bb6596f8fb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Aug 2009 23:58:44 -0500 Subject: [PATCH 15/16] windows.ole32: don't pull in debugger, reduces terrain demo deployed size by ~30kb --- basis/windows/ole32/ole32.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor index 864700cb0f..d6a08325d9 100755 --- a/basis/windows/ole32/ole32.factor +++ b/basis/windows/ole32/ole32.factor @@ -1,5 +1,5 @@ USING: alien alien.syntax alien.c-types alien.strings math -kernel sequences windows.errors windows.types debugger io +kernel sequences windows.errors windows.types io accessors math.order namespaces make math.parser windows.kernel32 combinators locals specialized-arrays.direct.uchar ; IN: windows.ole32 @@ -116,11 +116,10 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ; : succeeded? ( hresult -- ? ) 0 HEX: 7FFFFFFF between? ; -TUPLE: ole32-error error-code ; -C: ole32-error +TUPLE: ole32-error code message ; -M: ole32-error error. - "COM method failed: " print error-code>> n>win32-error-string print ; +: ( code -- error ) + dup n>win32-error-string \ ole32-error boa ; : ole32-error ( hresult -- ) dup succeeded? [ drop ] [ throw ] if ; From 79a3f6b0d5fb09ed019a8fd9e6b1b01c3f8c388b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Aug 2009 23:59:24 -0500 Subject: [PATCH 16/16] compiler: inline singleton predicates, and optimize predicate engines, reduces terrain demo deployed size by ~20kb --- basis/compiler/compiler.factor | 2 +- basis/compiler/tree/finalization/finalization.factor | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) mode change 100644 => 100755 basis/compiler/compiler.factor mode change 100644 => 100755 basis/compiler/tree/finalization/finalization.factor diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor old mode 100644 new mode 100755 index 3b8d996f34..504acc74b0 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -120,7 +120,7 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ; } cond ; : optimize? ( word -- ? ) - { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ; + single-generic? not ; : contains-breakpoints? ( -- ? ) dependencies get keys [ "break?" word-prop ] any? ; diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor old mode 100644 new mode 100755 index 9b278dde9b..fca35a5653 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences words memoize combinators -classes classes.builtin classes.tuple math.partial-dispatch -fry assocs combinators.short-circuit +classes classes.builtin classes.tuple classes.singleton +math.partial-dispatch fry assocs combinators.short-circuit compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -45,6 +45,7 @@ M: predicate finalize-word "predicating" word-prop { { [ dup builtin-class? ] [ drop word>> cached-expansion ] } { [ dup tuple-class? ] [ drop word>> def>> splice-final ] } + { [ dup singleton-class? ] [ drop word>> def>> splice-final ] } [ drop ] } cond ;