From 625d4037feea41d05f3157a277c82db800de5651 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 17 Apr 2008 12:22:04 -0500 Subject: [PATCH 01/13] Minor tweak to project-euler --- extra/project-euler/150/150.factor | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index 5b22a1b9f6..5d83f5a732 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -1,15 +1,21 @@ ! Copyright (c) 2008 Eric Mertens ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences locals ; +USING: kernel math sequences sequences.private locals hints ; IN: project-euler.150 +PRIVATE> USING: arrays kernel.private ; :: (euler150) ( m -- n ) [let | table [ sums-triangle ] | m [| x | x 1+ [| y | m x - [| z | - x z + table nth - [ y z + 1+ swap nth ] - [ y swap nth ] bi - - ] map partial-sums infimum + x z + table nth-unsafe + [ y z + 1+ swap nth-unsafe ] + [ y swap nth-unsafe ] bi - + ] map partial-sum-infimum ] map-infimum ] map-infimum ] ; +HINTS: (euler150) fixnum ; + : euler150 ( -- n ) 1000 (euler150) ; From 390afacac89026ced32dd3052bfe557937b2ef8f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 17 Apr 2008 12:22:24 -0500 Subject: [PATCH 02/13] Better modular arithmetic optmizer --- core/inference/class/class-tests.factor | 50 +++++++++++++++++- core/math/integers/integers-tests.factor | 7 +++ core/math/math-docs.factor | 12 ++--- core/math/math.factor | 6 ++- core/optimizer/math/math.factor | 56 +++++++++++++++++++-- extra/math/functions/functions-docs.factor | 11 ++-- extra/math/functions/functions-tests.factor | 3 -- extra/math/functions/functions.factor | 3 -- 8 files changed, 125 insertions(+), 23 deletions(-) diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 038ab1d230..ac64b53070 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -13,9 +13,10 @@ system layouts vectors ; ! Ensure type inference works as it is supposed to by checking ! if various methods get inlined -: inlined? ( quot word -- ? ) +: inlined? ( quot seq/word -- ? ) + dup word? [ 1array ] when swap dataflow optimize - [ node-param eq? ] with node-exists? not ; + [ node-param swap member? ] with node-exists? not ; GENERIC: mynot ( x -- y ) @@ -323,3 +324,48 @@ cell-bits 32 = [ ] when ] \ + inlined? ] unit-test + +[ f ] [ + [ + 256 mod + ] { mod fixnum-mod } inlined? +] unit-test + +[ f ] [ + [ + dup 0 >= [ 256 mod ] when + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare dup 0 >= [ 256 mod ] when + ] { mod fixnum-mod } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare 256 rem + ] { mod fixnum-mod } inlined? +] unit-test + +! [ t ] [ +! [ +! { integer } declare [ 256 mod ] map +! ] { mod fixnum-mod } inlined? +! ] unit-test +! +! [ t ] [ +! [ +! { integer } declare [ 0 >= ] map +! ] { >= fixnum>= } inlined? +! ] unit-test + +[ t ] [ + [ + { integer } declare + dup 0 >= [ + 615949 * 797807 + 20 2^ mod dup 19 2^ - + ] [ dup ] if + ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? +] unit-test diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index eebc45511a..fe8e5bddc8 100755 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -184,3 +184,10 @@ unit-test [ HEX: 988a259c3433f237 ] [ B{ HEX: 37 HEX: f2 HEX: 33 HEX: 34 HEX: 9c HEX: 25 HEX: 8a HEX: 98 } byte-array>bignum ] unit-test + +[ t ] [ 256 power-of-2? ] unit-test +[ f ] [ 123 power-of-2? ] unit-test + +[ f ] [ -128 power-of-2? ] unit-test +[ f ] [ 0 power-of-2? ] unit-test +[ t ] [ 1 power-of-2? ] unit-test diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 5533c00090..c8a763b5f7 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel sequences quotations -math.private math.functions ; +math.private ; IN: math ARTICLE: "division-by-zero" "Division by zero" @@ -26,17 +26,13 @@ $nl { $subsection < } { $subsection <= } { $subsection > } -{ $subsection >= } -"Inexact comparison:" -{ $subsection ~ } ; +{ $subsection >= } ; ARTICLE: "modular-arithmetic" "Modular arithmetic" { $subsection mod } { $subsection rem } { $subsection /mod } { $subsection /i } -{ $subsection mod-inv } -{ $subsection ^mod } { $see-also "integer-functions" } ; ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic" @@ -363,6 +359,10 @@ HELP: next-power-of-2 { $values { "m" "a non-negative integer" } { "n" "an integer" } } { $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ; +HELP: power-of-2? +{ $values { "n" integer } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "n" } " is a power of 2." } ; + HELP: each-integer { $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- )" } } } { $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } "." } diff --git a/core/math/math.factor b/core/math/math.factor index 064b488ac3..2b33c8b40b 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -121,7 +121,11 @@ M: float fp-nan? : next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable -: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline +: power-of-2? ( n -- ? ) + dup 0 < [ drop f ] [ dup 1- bitand zero? ] if ; foldable + +: align ( m w -- n ) + 1- [ + ] keep bitnot bitand ; inline fixnum consumed-by? ; +: coerced-to-fixnum? ( #call -- ? ) + dup dup node-in-d [ node-class integer class< ] with all? + [ \ >fixnum consumed-by? ] [ drop f ] if ; { { fixnum+ [ fixnum+fast ] } { fixnum- [ fixnum-fast ] } { fixnum* [ fixnum*fast ] } + { + [ >r >fixnum r> >fixnum fixnum+fast ] } + { - [ >r >fixnum r> >fixnum fixnum-fast ] } + { * [ >r >fixnum r> >fixnum fixnum*fast ] } } [ [ [ dup remove-overflow-check? - over coereced-to-fixnum? or + over coerced-to-fixnum? or ] , [ f splice-quot ] curry , ] { } make 1array define-optimizers @@ -467,3 +471,49 @@ most-negative-fixnum most-positive-fixnum [a,b] [ [ fixnum-shift-fast ] f splice-quot ] } } define-optimizers + +: convert-rem-to-and? ( #call -- ? ) + dup node-in-d { + { [ 2dup first node-class integer class< not ] [ f ] } + { [ 2dup second node-literal integer? not ] [ f ] } + { [ 2dup second node-literal power-of-2? not ] [ f ] } + [ t ] + } cond 2nip ; + +: convert-mod-to-and? ( #call -- ? ) + dup dup node-in-d first node-interval 0 [a,inf] interval-subset? + [ convert-rem-to-and? ] [ drop f ] if ; + +: convert-mod-to-and ( #call -- node ) + dup + dup node-in-d second node-literal 1- + [ nip bitand ] curry f splice-quot ; + +{ mod bignum-mod fixnum-mod } [ + { + { + [ dup convert-mod-to-and? ] + [ convert-mod-to-and ] + } + } define-optimizers +] each + +\ rem { + { + [ dup convert-rem-to-and? ] + [ convert-mod-to-and ] + } +} define-optimizers + +: fixnumify-bitand? ( #call -- ? ) + dup node-in-d second node-interval fixnum fits? ; + +: fixnumify-bitand ( #call -- node ) + [ >r >fixnum r> >fixnum fixnum-bitand ] f splice-quot ; + +\ bitand { + { + [ dup fixnumify-bitand? ] + [ fixnumify-bitand ] + } +} define-optimizers diff --git a/extra/math/functions/functions-docs.factor b/extra/math/functions/functions-docs.factor index f0819fb03e..35471653dc 100755 --- a/extra/math/functions/functions-docs.factor +++ b/extra/math/functions/functions-docs.factor @@ -7,6 +7,9 @@ ARTICLE: "integer-functions" "Integer functions" { $subsection gcd } { $subsection log2 } { $subsection next-power-of-2 } +"Modular exponentiation:" +{ $subsection ^mod } +{ $subsection mod-inv } "Tests:" { $subsection power-of-2? } { $subsection even? } @@ -33,7 +36,9 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions" { $subsection ceiling } { $subsection floor } { $subsection truncate } -{ $subsection round } ; +{ $subsection round } +"Inexact comparison:" +{ $subsection ~ } ; ARTICLE: "power-functions" "Powers and logarithms" "Squares:" @@ -107,10 +112,6 @@ HELP: >rect { $values { "z" number } { "x" real } { "y" real } } { $description "Extracts the real and imaginary components of a complex number." } ; -HELP: power-of-2? -{ $values { "n" integer } { "?" "a boolean" } } -{ $description "Tests if " { $snippet "n" } " is a power of 2." } ; - HELP: align { $values { "m" integer } { "w" "a power of 2" } { "n" "an integer multiple of " { $snippet "w" } } } { $description "Outputs the least multiple of " { $snippet "w" } " greater than " { $snippet "m" } "." } diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index 6773678dab..8c71eb545b 100755 --- a/extra/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -81,9 +81,6 @@ IN: math.functions.tests [ 1/8 ] [ 2 -3 ^ ] unit-test [ t ] [ 1 100 shift 2 100 ^ = ] unit-test -[ t ] [ 256 power-of-2? ] unit-test -[ f ] [ 123 power-of-2? ] unit-test - [ 1 ] [ 7/8 ceiling ] unit-test [ 2 ] [ 3/2 ceiling ] unit-test [ 0 ] [ -7/8 ceiling ] unit-test diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index b3cfba8650..632939ff71 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -102,9 +102,6 @@ M: real absq sq ; [ ~abs ] } cond ; -: power-of-2? ( n -- ? ) - dup 0 < [ drop f ] [ dup 1- bitand zero? ] if ; foldable - : >rect ( z -- x y ) dup real-part swap imaginary-part ; inline : conjugate ( z -- z* ) >rect neg rect> ; inline From 80ee4f8771040cec8de491d71b0839dfbb5f3264 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 17 Apr 2008 12:54:47 -0500 Subject: [PATCH 03/13] Code cleanup --- core/inference/class/class-tests.factor | 30 +++++++++++++++++-------- core/inference/class/class.factor | 12 ++++------ 2 files changed, 25 insertions(+), 17 deletions(-) diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index ac64b53070..a2bd2453f4 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -349,6 +349,27 @@ cell-bits 32 = [ ] { mod fixnum-mod } inlined? ] unit-test +[ t ] [ + [ + { integer } declare [ 256 rem ] map + ] { mod fixnum-mod rem } inlined? +] unit-test + +[ t ] [ + [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? +] unit-test + +[ t ] [ + [ + { integer } declare + dup 0 >= [ + 615949 * 797807 + 20 2^ mod dup 19 2^ - + ] [ dup ] if + ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? +] unit-test + +! Later + ! [ t ] [ ! [ ! { integer } declare [ 256 mod ] map @@ -360,12 +381,3 @@ cell-bits 32 = [ ! { integer } declare [ 0 >= ] map ! ] { >= fixnum>= } inlined? ! ] unit-test - -[ t ] [ - [ - { integer } declare - dup 0 >= [ - 615949 * 797807 + 20 2^ mod dup 19 2^ - - ] [ dup ] if - ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? -] unit-test diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 033d2cce7a..1c0f5a46e1 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -260,18 +260,14 @@ DEFER: (infer-classes) : merge-classes ( nodes node -- ) >r (merge-classes) r> set-classes ; -: (merge-intervals) ( nodes quot -- seq ) - >r - [ node-input-intervals ] map - f pad-all flip - r> map ; inline - : set-intervals ( seq node -- ) node-out-d [ set-value-interval* ] 2reverse-each ; : merge-intervals ( nodes node -- ) - >r [ dup first [ interval-union ] reduce ] - (merge-intervals) r> set-intervals ; + >r + [ node-input-intervals ] map f pad-all flip + [ dup first [ interval-union ] reduce ] map + r> set-intervals ; : annotate-merge ( nodes #merge/#entry -- ) [ merge-classes ] [ merge-intervals ] 2bi ; From 608a1c03f41483ccfea992ffe8bd041e999fbcb0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 17 Apr 2008 14:34:32 -0500 Subject: [PATCH 04/13] Improve type inference for recursive functions --- core/inference/class/class-tests.factor | 19 ++++++++++++ core/optimizer/math/math.factor | 40 ++++--------------------- 2 files changed, 25 insertions(+), 34 deletions(-) diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index a2bd2453f4..4d215bf6f5 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -368,6 +368,25 @@ cell-bits 32 = [ ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? ] unit-test +: fib ( m -- n ) + dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline + +[ t ] [ + [ 27.0 fib ] { < - } inlined? +] unit-test + +[ t ] [ + [ 27 fib ] { < - } inlined? +] unit-test + +[ t ] [ + [ 27 >bignum fib ] { < - } inlined? +] unit-test + +[ f ] [ + [ 27/2 fib ] { < - } inlined? +] unit-test + ! Later ! [ t ] [ diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 218d5465af..4afb860795 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -10,12 +10,7 @@ classes.algebra generic.math optimizer.pattern-match optimizer.backend optimizer.def-use optimizer.inlining generic.standard system ; -{ + bignum+ float+ fixnum+fast } { - { { number 0 } [ drop ] } - { { 0 number } [ nip ] } -} define-identities - -{ fixnum+ } { +{ + bignum+ float+ fixnum+ fixnum+fast } { { { number 0 } [ drop ] } { { 0 number } [ nip ] } } define-identities @@ -41,7 +36,7 @@ generic.standard system ; { { @ @ } [ 2drop t ] } } define-identities -{ * fixnum* bignum* float* } { +{ * fixnum* fixnum*fast bignum* float* } { { { number 1 } [ drop ] } { { 1 number } [ nip ] } { { number 0 } [ nip ] } @@ -89,7 +84,7 @@ generic.standard system ; } define-identities : math-closure ( class -- newclass ) - { fixnum integer rational real } + { fixnum bignum integer rational float real number } [ class< ] with find nip number or ; : fits? ( interval class -- ? ) @@ -354,15 +349,17 @@ most-negative-fixnum most-positive-fixnum [a,b] { + [ fixnum+fast ] } { - [ fixnum-fast ] } { * [ fixnum*fast ] } + { shift [ fixnum-shift-fast ] } { fixnum+ [ fixnum+fast ] } { fixnum- [ fixnum-fast ] } { fixnum* [ fixnum*fast ] } + { fixnum-shift [ fixnum-shift-fast ] } ! these are here as an optimization. if they weren't given ! explicitly, the same would be inferred after an extra ! optimization step (see optimistic-inline?) { 1+ [ 1 fixnum+fast ] } { 1- [ 1 fixnum-fast ] } - { 2/ [ -1 fixnum-shift ] } + { 2/ [ -1 fixnum-shift-fast ] } { neg [ 0 swap fixnum-fast ] } } [ [ @@ -447,31 +444,6 @@ most-negative-fixnum most-positive-fixnum [a,b] ] { } make 1array define-optimizers ] assoc-each -: fixnum-shift-fast-pos? ( node -- ? ) - #! Shifting 1 to the left won't overflow if the shift - #! count is small enough - dup dup node-in-d first node-literal 1 = [ - dup node-in-d second node-interval - 0 cell-bits tag-bits get - 2 - [a,b] interval-subset? - ] [ drop f ] if ; - -: fixnum-shift-fast-neg? ( node -- ? ) - #! Shifting any number to the right won't overflow if the - #! shift count is small enough - dup node-in-d second node-interval - cell-bits 1- neg 0 [a,b] interval-subset? ; - -: fixnum-shift-fast? ( node -- ? ) - dup fixnum-shift-fast-pos? - [ drop t ] [ fixnum-shift-fast-neg? ] if ; - -\ fixnum-shift { - { - [ dup fixnum-shift-fast? ] - [ [ fixnum-shift-fast ] f splice-quot ] - } -} define-optimizers - : convert-rem-to-and? ( #call -- ? ) dup node-in-d { { [ 2dup first node-class integer class< not ] [ f ] } From a8d0eecd9e34b005aac5c540e028e14c62523657 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 17 Apr 2008 21:26:37 -0500 Subject: [PATCH 05/13] Add DLLEXPORT --- vm/ffi_test.h | 2 ++ 1 file changed, 2 insertions(+) diff --git a/vm/ffi_test.h b/vm/ffi_test.h index aac5d32f93..2edebd96f1 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -61,3 +61,5 @@ DLLEXPORT double ffi_test_35(struct test_struct_11 x, int y); struct test_struct_12 { int a; double x; }; DLLEXPORT double ffi_test_36(struct test_struct_12 x); + +DLLEXPORT int ffi_test_37(int (*f)(int, int, int)); From 2d2b3ec9043a9e956bd9fc6a16c37aa39bf584f1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 18 Apr 2008 16:51:09 -0500 Subject: [PATCH 06/13] Partial dispatch on integer operations --- core/generic/generic.factor | 3 + core/inference/class/class-tests.factor | 139 ++++++++++-- core/math/intervals/intervals.factor | 2 + core/math/math.factor | 18 +- core/optimizer/inlining/inlining-tests.factor | 10 + core/optimizer/inlining/inlining.factor | 37 ++-- core/optimizer/known-words/known-words.factor | 12 +- core/optimizer/math/math.factor | 204 +++++++----------- .../math/partial/partial-tests.factor | 13 ++ core/optimizer/math/partial/partial.factor | 172 +++++++++++++++ 10 files changed, 433 insertions(+), 177 deletions(-) create mode 100644 core/optimizer/inlining/inlining-tests.factor create mode 100644 core/optimizer/math/partial/partial-tests.factor create mode 100644 core/optimizer/math/partial/partial.factor diff --git a/core/generic/generic.factor b/core/generic/generic.factor index caae16e8ed..6c59d76d07 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -29,6 +29,9 @@ PREDICATE: method-spec < pair : order ( generic -- seq ) "methods" word-prop keys sort-classes ; +: specific-method ( class word -- class ) + order min-class ; + GENERIC: effective-method ( ... generic -- method ) : next-method-class ( class generic -- class/f ) diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 4d215bf6f5..dcd83f7f7c 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -4,7 +4,7 @@ inference.dataflow optimizer tools.test kernel.private generic sequences words inference.class quotations alien alien.c-types strings sbufs sequences.private slots.private combinators definitions compiler.units -system layouts vectors ; +system layouts vectors optimizer.math.partial ; ! Make sure these compile even though this is invalid code [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test @@ -18,6 +18,11 @@ system layouts vectors ; swap dataflow optimize [ node-param swap member? ] with node-exists? not ; +[ f ] [ + [ { integer } declare >fixnum ] + \ >fixnum inlined? +] unit-test + GENERIC: mynot ( x -- y ) M: f mynot drop t ; @@ -110,12 +115,17 @@ M: object xyz ; [ { fixnum } declare [ ] times ] \ fixnum+ inlined? ] unit-test -[ f ] [ +[ t ] [ [ { integer fixnum } declare dupd < [ 1 + ] when ] \ + inlined? ] unit-test -[ f ] [ [ dup 0 < [ neg ] when ] \ neg inlined? ] unit-test +[ f ] [ + [ { integer fixnum } declare dupd < [ 1 + ] when ] + \ +-integer-fixnum inlined? +] unit-test + +[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test [ f ] [ [ @@ -138,13 +148,13 @@ M: object xyz ; DEFER: blah -[ t ] [ +[ ] [ [ \ blah [ dup V{ } eq? [ foo ] when ] dup second dup push define ] with-compilation-unit - \ blah compiled? + \ blah word-def dataflow optimize drop ] unit-test GENERIC: detect-fx ( n -- n ) @@ -159,14 +169,20 @@ M: fixnum detect-fx ; ] \ detect-fx inlined? ] unit-test +[ t ] [ + [ + 1000000000000000000000000000000000 [ ] times + ] \ + inlined? +] unit-test [ f ] [ [ 1000000000000000000000000000000000 [ ] times - ] \ 1+ inlined? + ] \ +-integer-fixnum inlined? ] unit-test [ f ] [ - [ { bignum } declare [ ] times ] \ 1+ inlined? + [ { bignum } declare [ ] times ] + \ +-integer-fixnum inlined? ] unit-test @@ -359,15 +375,6 @@ cell-bits 32 = [ [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? ] unit-test -[ t ] [ - [ - { integer } declare - dup 0 >= [ - 615949 * 797807 + 20 2^ mod dup 19 2^ - - ] [ dup ] if - ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? -] unit-test - : fib ( m -- n ) dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline @@ -387,6 +394,106 @@ cell-bits 32 = [ [ 27/2 fib ] { < - } inlined? ] unit-test +[ t ] [ + [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined? +] unit-test + +[ f ] [ + [ { integer } declare 10 [ -1 shift ] times ] \ shift inlined? +] unit-test + +[ f ] [ + [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ] + \ fixnum-bitand inlined? +] unit-test + +[ t ] [ + [ { integer } declare 127 bitand 3 + ] + { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined? +] unit-test + +[ f ] [ + [ { integer } declare 127 bitand 3 + ] + { >fixnum } inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare [ drop ] each-integer ] + { < <-integer-fixnum +-integer-fixnum + } inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare length [ drop ] each-integer ] + { < <-integer-fixnum +-integer-fixnum + } inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare [ drop ] each ] + { < <-integer-fixnum +-integer-fixnum + } inlined? +] unit-test + +[ t ] [ + [ { fixnum } declare 0 [ + ] reduce ] + { < <-integer-fixnum } inlined? +] unit-test + +[ f ] [ + [ { fixnum } declare 0 [ + ] reduce ] + \ +-integer-fixnum inlined? +] unit-test + +[ t ] [ + [ + { integer } declare + dup 0 >= [ + 615949 * 797807 + 20 2^ mod dup 19 2^ - + ] [ dup ] if + ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? +] unit-test + +[ t ] [ + [ + { fixnum } declare + 615949 * 797807 + 20 2^ mod dup 19 2^ - + ] { >fixnum } inlined? +] unit-test + +[ f ] [ + [ + { integer } declare [ ] map + ] \ >fixnum inlined? +] unit-test + +[ f ] [ + [ + { integer } declare { } set-nth-unsafe + ] \ >fixnum inlined? +] unit-test + +[ f ] [ + [ + { integer } declare 1 + { } set-nth-unsafe + ] \ >fixnum inlined? +] unit-test + +[ t ] [ + [ + { integer } declare 0 swap + [ + drop 615949 * 797807 + 20 2^ rem dup 19 2^ - + ] map + ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined? +] unit-test + +[ t ] [ + [ + { fixnum } declare 0 swap + [ + drop 615949 * 797807 + 20 2^ rem dup 19 2^ - + ] map + ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined? +] unit-test + ! Later ! [ t ] [ diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index 4ca1a8637c..77d60e67f8 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -96,6 +96,8 @@ C: interval : interval-bitnot ( i1 -- i2 ) interval-neg interval-1- ; +: interval-sq ( i1 -- i2 ) dup interval* ; + : make-interval ( from to -- int ) over first over first { { [ 2dup > ] [ 2drop 2drop f ] } diff --git a/core/math/math.factor b/core/math/math.factor index 2b33c8b40b..6a56baea3a 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -55,26 +55,26 @@ GENERIC: zero? ( x -- ? ) foldable M: object zero? drop f ; -: 1+ ( x -- y ) 1 + ; foldable -: 1- ( x -- y ) 1 - ; foldable -: 2/ ( x -- y ) -1 shift ; foldable -: sq ( x -- y ) dup * ; foldable -: neg ( x -- -x ) 0 swap - ; foldable -: recip ( x -- y ) 1 swap / ; foldable +: 1+ ( x -- y ) 1 + ; inline +: 1- ( x -- y ) 1 - ; inline +: 2/ ( x -- y ) -1 shift ; inline +: sq ( x -- y ) dup * ; inline +: neg ( x -- -x ) 0 swap - ; inline +: recip ( x -- y ) 1 swap / ; inline : ?1+ [ 1+ ] [ 0 ] if* ; inline : /f ( x y -- z ) >r >float r> >float float/f ; inline -: max ( x y -- z ) [ > ] most ; foldable -: min ( x y -- z ) [ < ] most ; foldable +: max ( x y -- z ) [ > ] most ; inline +: min ( x y -- z ) [ < ] most ; inline : between? ( x y z -- ? ) pick >= [ >= ] [ 2drop f ] if ; inline : rem ( x y -- z ) tuck mod over + swap mod ; foldable -: sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable +: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline : [-] ( x y -- z ) - 0 max ; inline diff --git a/core/optimizer/inlining/inlining-tests.factor b/core/optimizer/inlining/inlining-tests.factor new file mode 100644 index 0000000000..608054becb --- /dev/null +++ b/core/optimizer/inlining/inlining-tests.factor @@ -0,0 +1,10 @@ +IN: optimizer.inlining.tests +USING: tools.test optimizer.inlining ; + +\ word-flat-length must-infer + +\ inlining-math-method must-infer + +\ optimistic-inline? must-infer + +\ find-identity must-infer diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 8447d1be5f..e74e8b1de2 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -3,10 +3,11 @@ USING: arrays generic assocs inference inference.class inference.dataflow inference.backend inference.state io kernel math namespaces sequences vectors words quotations hashtables -combinators classes classes.algebra generic.math continuations -optimizer.def-use optimizer.backend generic.standard -optimizer.specializers optimizer.def-use optimizer.pattern-match -generic.standard optimizer.control kernel.private ; +combinators classes classes.algebra generic.math +optimizer.math.partial continuations optimizer.def-use +optimizer.backend generic.standard optimizer.specializers +optimizer.def-use optimizer.pattern-match generic.standard +optimizer.control kernel.private ; IN: optimizer.inlining : remember-inlining ( node history -- ) @@ -53,8 +54,6 @@ DEFER: (flat-length) [ word-def (flat-length) ] with-scope ; ! Single dispatch method inlining optimization -: specific-method ( class word -- class ) order min-class ; - : node-class# ( node n -- class ) over node-in-d ?nth node-class ; @@ -79,21 +78,31 @@ DEFER: (flat-length) object } [ class< ] with find nip ; -: math-both-known? ( word left right -- ? ) - math-class-max swap specific-method ; - -: inline-math-method ( #call word -- node ) - over node-input-classes +: inlining-math-method ( #call word -- quot/f ) + swap node-input-classes [ first normalize-math-class ] [ second normalize-math-class ] bi - 3dup math-both-known? - [ math-method f splice-quot ] - [ 2drop 2drop t ] if ; + 3dup math-both-known? [ math-method* ] [ 3drop f ] if ; + +: inline-math-method ( #call word -- node/t ) + [ drop ] [ inlining-math-method ] 2bi + dup [ f splice-quot ] [ 2drop t ] if ; + +: inline-math-partial ( #call word -- node/t ) + [ drop ] + [ + "derived-from" word-prop first + inlining-math-method dup + ] + [ nip 1quotation ] 2tri + [ = not ] [ drop ] 2bi and + [ f splice-quot ] [ 2drop t ] if ; : inline-method ( #call -- node ) dup node-param { { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } + { [ dup math-partial? ] [ inline-math-partial ] } [ 2drop t ] } cond ; diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index cf71af216e..91d0c1c0de 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -83,21 +83,11 @@ sequences.private combinators ; ] "constraints" set-word-prop ! eq? on the same object is always t -{ eq? bignum= float= number= = } { +{ eq? = } { { { @ @ } [ 2drop t ] } } define-identities ! Specializers -{ 1+ 1- sq neg recip sgn } [ - { number } "specializer" set-word-prop -] each - -\ 2/ { fixnum } "specializer" set-word-prop - -{ min max } [ - { number number } "specializer" set-word-prop -] each - { first first2 first3 first4 } [ { array } "specializer" set-word-prop ] each diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 4afb860795..fe33c57d42 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -8,80 +8,91 @@ namespaces assocs quotations math.intervals sequences.private combinators splitting layouts math.parser classes classes.algebra generic.math optimizer.pattern-match optimizer.backend optimizer.def-use optimizer.inlining -generic.standard system ; +optimizer.math.partial generic.standard system ; -{ + bignum+ float+ fixnum+ fixnum+fast } { +: define-math-identities ( word identities -- ) + >r all-derived-ops r> define-identities ; + +\ number= { + { { @ @ } [ 2drop t ] } +} define-math-identities + +\ + { { { number 0 } [ drop ] } { { 0 number } [ nip ] } -} define-identities +} define-math-identities -{ - fixnum- bignum- float- fixnum-fast } { +\ - { { { number 0 } [ drop ] } { { @ @ } [ 2drop 0 ] } -} define-identities +} define-math-identities -{ < fixnum< bignum< float< } { +\ < { { { @ @ } [ 2drop f ] } -} define-identities +} define-math-identities -{ <= fixnum<= bignum<= float<= } { +\ <= { { { @ @ } [ 2drop t ] } -} define-identities +} define-math-identities -{ > fixnum> bignum> float>= } { +\ > { { { @ @ } [ 2drop f ] } -} define-identities +} define-math-identities -{ >= fixnum>= bignum>= float>= } { +\ >= { { { @ @ } [ 2drop t ] } -} define-identities +} define-math-identities -{ * fixnum* fixnum*fast bignum* float* } { +\ * { { { number 1 } [ drop ] } { { 1 number } [ nip ] } { { number 0 } [ nip ] } { { 0 number } [ drop ] } { { number -1 } [ drop 0 swap - ] } { { -1 number } [ nip 0 swap - ] } -} define-identities +} define-math-identities -{ / fixnum/i bignum/i float/f } { +\ / { { { number 1 } [ drop ] } { { number -1 } [ drop 0 swap - ] } -} define-identities +} define-math-identities -{ fixnum-mod bignum-mod } { - { { number 1 } [ 2drop 0 ] } -} define-identities +\ mod { + { { integer 1 } [ 2drop 0 ] } +} define-math-identities -{ bitand fixnum-bitand bignum-bitand } { +\ rem { + { { integer 1 } [ 2drop 0 ] } +} define-math-identities + +\ bitand { { { number -1 } [ drop ] } { { -1 number } [ nip ] } { { @ @ } [ drop ] } { { number 0 } [ nip ] } { { 0 number } [ drop ] } -} define-identities +} define-math-identities -{ bitor fixnum-bitor bignum-bitor } { +\ bitor { { { number 0 } [ drop ] } { { 0 number } [ nip ] } { { @ @ } [ drop ] } { { number -1 } [ nip ] } { { -1 number } [ drop ] } -} define-identities +} define-math-identities -{ bitxor fixnum-bitxor bignum-bitxor } { +\ bitxor { { { number 0 } [ drop ] } { { 0 number } [ nip ] } { { number -1 } [ drop bitnot ] } { { -1 number } [ nip bitnot ] } { { @ @ } [ 2drop 0 ] } -} define-identities +} define-math-identities -{ shift fixnum-shift fixnum-shift-fast bignum-shift } { +\ shift { { { 0 number } [ drop ] } { { number 0 } [ drop ] } -} define-identities +} define-math-identities : math-closure ( class -- newclass ) { fixnum bignum integer rational float real number } @@ -126,15 +137,9 @@ generic.standard system ; r> post-process ; inline { - { 1+ integer interval-1+ } - { 1- integer interval-1- } - { neg integer interval-neg } - { shift integer interval-recip } { bitnot fixnum interval-bitnot } { fixnum-bitnot f interval-bitnot } { bignum-bitnot f interval-bitnot } - { 2/ fixnum interval-2/ } - { sq integer f } } [ first3 [ math-output-class/interval-1 @@ -164,35 +169,16 @@ generic.standard system ; { * integer interval* } { / rational interval/ } { /i integer interval/i } - - { fixnum+ f interval+ } - { fixnum+fast f interval+ } - { fixnum- f interval- } - { fixnum-fast f interval- } - { fixnum* f interval* } - { fixnum*fast f interval* } - { fixnum/i f interval/i } - - { bignum+ f interval+ } - { bignum- f interval- } - { bignum* f interval* } - { bignum/i f interval/i } - { bignum-shift f interval-shift-safe } - - { float+ f interval+ } - { float- f interval- } - { float* f interval* } - { float/f f interval/ } - - { min fixnum interval-min } - { max fixnum interval-max } + { shift f interval-shift-safe } } [ first3 [ - math-output-class/interval-2 - ] 2curry "output-classes" set-word-prop + [ + math-output-class/interval-2 + ] 2curry "output-classes" set-word-prop + ] 2curry each-derived-op ] each -{ fixnum-shift fixnum-shift-fast shift } [ +\ shift [ [ dup node-in-d second value-interval* @@ -200,7 +186,7 @@ generic.standard system ; \ interval-shift-safe math-output-class/interval-2 ] "output-classes" set-word-prop -] each +] each-derived-op : real-value? ( value -- n ? ) dup value? [ value-literal dup real? ] [ drop f f ] if ; @@ -231,21 +217,17 @@ generic.standard system ; { { mod fixnum mod-range } - { fixnum-mod f mod-range } - { bignum-mod f mod-range } - { float-mod f mod-range } - { rem integer rem-range } { bitand fixnum bitand-range } - { fixnum-bitand f bitand-range } - { bitor fixnum f } { bitxor fixnum f } } [ first3 [ - math-output-class/interval-special - ] 2curry "output-classes" set-word-prop + [ + math-output-class/interval-special + ] 2curry "output-classes" set-word-prop + ] 2curry each-derived-op ] each : twiddle-interval ( i1 -- i2 ) @@ -275,26 +257,12 @@ generic.standard system ; { <= assume<= assume> } { > assume> assume<= } { >= assume>= assume< } - - { fixnum< assume< assume>= } - { fixnum<= assume<= assume> } - { fixnum> assume> assume<= } - { fixnum>= assume>= assume< } - - { bignum< assume< assume>= } - { bignum<= assume<= assume> } - { bignum> assume> assume<= } - { bignum>= assume>= assume< } - - { float< assume< assume>= } - { float<= assume<= assume> } - { float> assume> assume<= } - { float>= assume>= assume< } } [ - first3 - [ - [ comparison-constraints ] with-scope - ] 2curry "constraints" set-word-prop + first3 [ + [ + [ comparison-constraints ] with-scope + ] 2curry "constraints" set-word-prop + ] 2curry each-derived-op ] each { @@ -347,20 +315,15 @@ most-negative-fixnum most-positive-fixnum [a,b] { { + [ fixnum+fast ] } + { +-integer-fixnum [ fixnum+fast ] } { - [ fixnum-fast ] } { * [ fixnum*fast ] } + { *-integer-fixnum [ fixnum*fast ] } { shift [ fixnum-shift-fast ] } { fixnum+ [ fixnum+fast ] } { fixnum- [ fixnum-fast ] } { fixnum* [ fixnum*fast ] } { fixnum-shift [ fixnum-shift-fast ] } - ! these are here as an optimization. if they weren't given - ! explicitly, the same would be inferred after an extra - ! optimization step (see optimistic-inline?) - { 1+ [ 1 fixnum+fast ] } - { 1- [ 1 fixnum-fast ] } - { 2/ [ -1 fixnum-shift-fast ] } - { neg [ 0 swap fixnum-fast ] } } [ [ [ dup remove-overflow-check? ] , @@ -394,26 +357,13 @@ most-negative-fixnum most-positive-fixnum [a,b] { <= interval<= } { > interval> } { >= interval>= } - - { fixnum< interval< } - { fixnum<= interval<= } - { fixnum> interval> } - { fixnum>= interval>= } - - { bignum< interval< } - { bignum<= interval<= } - { bignum> interval> } - { bignum>= interval>= } - - { float< interval< } - { float<= interval<= } - { float> interval> } - { float>= interval>= } } [ [ - dup [ dupd foldable-comparison? ] curry , - [ fold-comparison ] curry , - ] { } make 1array define-optimizers + [ + dup [ dupd foldable-comparison? ] curry , + [ fold-comparison ] curry , + ] { } make 1array define-optimizers + ] curry each-derived-op ] assoc-each ! The following words are handled in a similar way except if @@ -428,20 +378,20 @@ most-negative-fixnum most-positive-fixnum [a,b] [ \ >fixnum consumed-by? ] [ drop f ] if ; { - { fixnum+ [ fixnum+fast ] } - { fixnum- [ fixnum-fast ] } - { fixnum* [ fixnum*fast ] } - { + [ >r >fixnum r> >fixnum fixnum+fast ] } - { - [ >r >fixnum r> >fixnum fixnum-fast ] } - { * [ >r >fixnum r> >fixnum fixnum*fast ] } + { + [ [ >fixnum ] bi@ fixnum+fast ] } + { - [ [ >fixnum ] bi@ fixnum-fast ] } + { * [ [ >fixnum ] bi@ fixnum*fast ] } + { shift [ [ >fixnum ] bi@ fixnum-shift-fast ] } } [ - [ + >r derived-ops r> [ [ - dup remove-overflow-check? - over coerced-to-fixnum? or - ] , - [ f splice-quot ] curry , - ] { } make 1array define-optimizers + [ + dup remove-overflow-check? + over coerced-to-fixnum? or + ] , + [ f splice-quot ] curry , + ] { } make 1array define-optimizers + ] curry each ] assoc-each : convert-rem-to-and? ( #call -- ? ) @@ -461,14 +411,14 @@ most-negative-fixnum most-positive-fixnum [a,b] dup node-in-d second node-literal 1- [ nip bitand ] curry f splice-quot ; -{ mod bignum-mod fixnum-mod } [ +\ mod [ { { [ dup convert-mod-to-and? ] [ convert-mod-to-and ] } } define-optimizers -] each +] each-derived-op \ rem { { @@ -481,7 +431,7 @@ most-negative-fixnum most-positive-fixnum [a,b] dup node-in-d second node-interval fixnum fits? ; : fixnumify-bitand ( #call -- node ) - [ >r >fixnum r> >fixnum fixnum-bitand ] f splice-quot ; + [ [ >fixnum ] bi@ fixnum-bitand ] f splice-quot ; \ bitand { { diff --git a/core/optimizer/math/partial/partial-tests.factor b/core/optimizer/math/partial/partial-tests.factor new file mode 100644 index 0000000000..671933b682 --- /dev/null +++ b/core/optimizer/math/partial/partial-tests.factor @@ -0,0 +1,13 @@ +IN: optimizer.math.partial.tests +USING: optimizer.math.partial tools.test math kernel +sequences ; + +[ t ] [ \ + integer fixnum math-both-known? ] unit-test +[ t ] [ \ + bignum fixnum math-both-known? ] unit-test +[ t ] [ \ + integer bignum math-both-known? ] unit-test +[ t ] [ \ + float fixnum math-both-known? ] unit-test +[ f ] [ \ + real fixnum math-both-known? ] unit-test +[ f ] [ \ + object number math-both-known? ] unit-test +[ f ] [ \ number= fixnum object math-both-known? ] unit-test +[ t ] [ \ number= integer fixnum math-both-known? ] unit-test +[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test diff --git a/core/optimizer/math/partial/partial.factor b/core/optimizer/math/partial/partial.factor new file mode 100644 index 0000000000..bbe1d0a83f --- /dev/null +++ b/core/optimizer/math/partial/partial.factor @@ -0,0 +1,172 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel kernel.private math math.private words +sequences parser namespaces assocs quotations arrays +generic generic.math hashtables effects ; +IN: optimizer.math.partial + +! Partial dispatch. + +! This code will be overhauled and generalized when +! multi-methods go into the core. +PREDICATE: math-partial < word + "derived-from" word-prop >boolean ; + +: fixnum-integer-op ( a b fix-word big-word -- c ) + pick tag 0 eq? [ + drop execute + ] [ + >r drop >r fixnum>bignum r> r> execute + ] if ; inline + +: integer-fixnum-op ( a b fix-word big-word -- c ) + >r pick tag 0 eq? [ + r> drop execute + ] [ + drop fixnum>bignum r> execute + ] if ; inline + +: integer-integer-op ( a b fix-word big-word -- c ) + pick tag 0 eq? [ + integer-fixnum-op + ] [ + >r drop over tag 0 eq? [ + >r fixnum>bignum r> r> execute + ] [ + r> execute + ] if + ] if ; inline + +<< +: integer-op-combinator ( triple -- word ) + [ + [ second word-name % "-" % ] + [ third word-name % "-op" % ] + bi + ] "" make in get lookup ; + +: integer-op-word ( triple fix-word big-word -- word ) + [ + drop + word-name "fast" tail? >r + [ "-" % ] [ word-name % ] interleave + r> [ "-fast" % ] when + ] "" make in get create ; + +: integer-op-quot ( word fix-word big-word -- quot ) + rot integer-op-combinator 1quotation 2curry ; + +: define-integer-op-word ( word fix-word big-word -- ) + [ + [ integer-op-word ] [ integer-op-quot ] 3bi + 2 1 define-declared + ] + [ + [ integer-op-word ] [ 2drop ] 3bi + "derived-from" set-word-prop + ] 3bi ; + +: define-integer-op-words ( words fix-word big-word -- ) + [ define-integer-op-word ] 2curry each ; + +: integer-op-triples ( word -- triples ) + { + { fixnum integer } + { integer fixnum } + { integer integer } + } swap [ prefix ] curry map ; + +: define-integer-ops ( word fix-word big-word -- ) + >r >r integer-op-triples r> r> + [ define-integer-op-words ] + [ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ] + 3bi ; + +: define-math-ops ( op -- ) + { fixnum bignum float } + [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc + [ nip ] assoc-subset + [ word-def peek ] assoc-map % ; + +SYMBOL: math-ops + +[ + \ + define-math-ops + \ - define-math-ops + \ * define-math-ops + \ shift define-math-ops + \ mod define-math-ops + \ /i define-math-ops + + \ bitand define-math-ops + \ bitor define-math-ops + \ bitxor define-math-ops + + \ < define-math-ops + \ <= define-math-ops + \ > define-math-ops + \ >= define-math-ops + \ number= define-math-ops + + \ + \ fixnum+ \ bignum+ define-integer-ops + \ - \ fixnum- \ bignum- define-integer-ops + \ * \ fixnum* \ bignum* define-integer-ops + \ shift \ fixnum-shift \ bignum-shift define-integer-ops + \ mod \ fixnum-mod \ bignum-mod define-integer-ops + \ /i \ fixnum/i \ bignum/i define-integer-ops + + \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops + \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops + \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops + + \ < \ fixnum< \ bignum< define-integer-ops + \ <= \ fixnum<= \ bignum<= define-integer-ops + \ > \ fixnum> \ bignum> define-integer-ops + \ >= \ fixnum>= \ bignum>= define-integer-ops + \ number= \ eq? \ bignum= define-integer-ops +] { } make >hashtable math-ops set-global + +SYMBOL: fast-math-ops + +[ + { { + fixnum fixnum } fixnum+fast } , + { { - fixnum fixnum } fixnum-fast } , + { { * fixnum fixnum } fixnum*fast } , + { { shift fixnum fixnum } fixnum-shift-fast } , + + \ + \ fixnum+fast \ bignum+ define-integer-ops + \ - \ fixnum-fast \ bignum- define-integer-ops + \ * \ fixnum*fast \ bignum* define-integer-ops + \ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops +] { } make >hashtable fast-math-ops set-global + +>> + +: math-op ( word left right -- word' ? ) + 3array math-ops get at* ; + +: math-method* ( word left right -- quot ) + 3dup math-op + [ >r 3drop r> 1quotation ] [ drop math-method ] if ; + +: math-both-known? ( word left right -- ? ) + 3dup math-op + [ 2drop 2drop t ] + [ drop math-class-max swap specific-method >boolean ] if ; + +: (derived-ops) ( word assoc -- words ) + swap [ rot first eq? nip ] curry assoc-subset values ; + +: derived-ops ( word -- words ) + [ 1array ] + [ math-ops get (derived-ops) ] + bi append ; + +: fast-derived-ops ( word -- words ) + fast-math-ops get (derived-ops) ; + +: all-derived-ops ( word -- words ) + [ derived-ops ] [ fast-derived-ops ] bi append ; + +: each-derived-op ( word quot -- ) + >r derived-ops r> each ; inline From 7516041e3650adf3f9eb822f3901910e32ba2476 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 18 Apr 2008 16:56:47 -0500 Subject: [PATCH 07/13] Try to fix includes for stesch --- vm/os-macosx-ppc.h | 2 ++ vm/os-macosx-x86.32.h | 2 ++ vm/os-macosx-x86.64.h | 2 ++ 3 files changed, 6 insertions(+) diff --git a/vm/os-macosx-ppc.h b/vm/os-macosx-ppc.h index 640aeb796d..13213acbbc 100644 --- a/vm/os-macosx-ppc.h +++ b/vm/os-macosx-ppc.h @@ -8,6 +8,8 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible, http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org Modified for Factor by Slava Pestov */ +#include + #define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 2) #define MACH_EXC_STATE_TYPE ppc_exception_state_t diff --git a/vm/os-macosx-x86.32.h b/vm/os-macosx-x86.32.h index d5e5827a5c..7c830c775d 100644 --- a/vm/os-macosx-x86.32.h +++ b/vm/os-macosx-x86.32.h @@ -8,6 +8,8 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible, http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org Modified for Factor by Slava Pestov */ +#include + #define MACH_EXC_STATE_TYPE i386_exception_state_t #define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE #define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT diff --git a/vm/os-macosx-x86.64.h b/vm/os-macosx-x86.64.h index d2bb48c3fe..b11aa80ce8 100644 --- a/vm/os-macosx-x86.64.h +++ b/vm/os-macosx-x86.64.h @@ -8,6 +8,8 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible, http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org Modified for Factor by Slava Pestov and Daniel Ehrenberg */ +#include + #define MACH_EXC_STATE_TYPE x86_exception_state64_t #define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64 #define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT From 27d60007e2c512fdd5e23dfccefb7cd6d4adc0f7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 02:11:18 -0500 Subject: [PATCH 08/13] Clean up recursive benchmark a tad --- extra/benchmark/recursive/recursive.factor | 43 +++++++++++----------- 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/extra/benchmark/recursive/recursive.factor b/extra/benchmark/recursive/recursive.factor index ee66e303ec..f69547df60 100755 --- a/extra/benchmark/recursive/recursive.factor +++ b/extra/benchmark/recursive/recursive.factor @@ -1,38 +1,37 @@ +USING: math kernel hints prettyprint io combinators ; IN: benchmark.recursive -USING: math kernel hints prettyprint io ; : fib ( m -- n ) - dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; + dup 2 < [ drop 1 ] [ [ 1 - fib ] [ 2 - fib ] bi + ] if ; + inline : ack ( m n -- x ) - over zero? [ - nip 1+ - ] [ - dup zero? [ - drop 1- 1 ack - ] [ - dupd 1- ack >r 1- r> ack - ] if - ] if ; + { + { [ over zero? ] [ nip 1+ ] } + { [ dup zero? ] [ drop 1- 1 ack ] } + [ [ drop 1- ] [ 1- ack ] 2bi ack ] + } cond ; inline : tak ( x y z -- t ) - 2over swap < [ - [ rot 1- -rot tak ] 3keep - [ -rot 1- -rot tak ] 3keep - 1- -rot tak - tak - ] [ + 2over <= [ 2nip - ] if ; + ] [ + [ rot 1- -rot tak ] + [ -rot 1- -rot tak ] + [ 1- -rot tak ] + 3tri + tak + ] if ; inline : recursive ( n -- ) - 3 over ack . flush - dup 27.0 + fib . flush - 1- - dup 3 * over 2 * rot tak . flush + [ 3 swap ack . flush ] + [ 27.0 + fib . flush ] + [ 1- [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri 3 fib . flush 3.0 2.0 1.0 tak . flush ; +HINTS: recursive fixnum ; + : recursive-main 11 recursive ; MAIN: recursive-main From d7763d6b71c031da74f38933ebb4c99363a8a10a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 02:11:30 -0500 Subject: [PATCH 09/13] Add another unit test --- core/alien/compiler/compiler-tests.factor | 4 ++++ vm/ffi_test.c | 7 +++++++ vm/ffi_test.h | 2 ++ 3 files changed, 13 insertions(+) diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index f0c0706a3c..d1a14dd758 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -280,6 +280,10 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test +FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; + +[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test + ! Test callbacks : callback-1 "void" { } "cdecl" [ ] alien-callback ; diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 48b6297cb8..5dcff831df 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -260,3 +260,10 @@ int ffi_test_37(int (*f)(int, int, int)) fflush(stdout); return global_var; } + +unsigned long long ffi_test_38(unsigned long long x, unsigned long long y) +{ + return x * y; +} + + diff --git a/vm/ffi_test.h b/vm/ffi_test.h index 2edebd96f1..9a3f4dded2 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -63,3 +63,5 @@ struct test_struct_12 { int a; double x; }; DLLEXPORT double ffi_test_36(struct test_struct_12 x); DLLEXPORT int ffi_test_37(int (*f)(int, int, int)); + +DLLEXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long long y); From 3b795b6a079bccb7a7bb94d003bffd8279c8bfe5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 02:11:40 -0500 Subject: [PATCH 10/13] Fix class< bug --- core/classes/algebra/algebra-tests.factor | 44 ++++++++++++++++++++++- core/classes/algebra/algebra.factor | 7 ++-- 2 files changed, 46 insertions(+), 5 deletions(-) diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index d61b62af3b..dba97c16f5 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.algebra classes.private classes.union classes.mixin classes.predicate vectors definitions source-files compiler.units growable -random inference effects kernel.private ; +random inference effects kernel.private sbufs ; : class= [ class< ] 2keep swap class< and ; @@ -144,6 +144,48 @@ UNION: z1 b1 c1 ; [ f ] [ null class-not null class= ] unit-test +[ t ] [ + fixnum class-not + fixnum fixnum class-not class-or + class< +] unit-test + +! Test method inlining +[ f ] [ fixnum { } min-class ] unit-test + +[ string ] [ + \ string + [ integer string array reversed sbuf + slice vector quotation ] + sort-classes min-class +] unit-test + +[ fixnum ] [ + \ fixnum + [ fixnum integer object ] + sort-classes min-class +] unit-test + +[ integer ] [ + \ fixnum + [ integer float object ] + sort-classes min-class +] unit-test + +[ object ] [ + \ word + [ integer float object ] + sort-classes min-class +] unit-test + +[ reversed ] [ + \ reversed + [ integer reversed slice ] + sort-classes min-class +] unit-test + +[ f ] [ null { number fixnum null } min-class ] unit-test + ! Test for hangs? : random-class classes random ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index b7a3e074e5..f2941e3cef 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -77,10 +77,10 @@ C: anonymous-complement { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] } { [ over anonymous-union? ] [ left-anonymous-union< ] } { [ over anonymous-intersection? ] [ left-anonymous-intersection< ] } - { [ over anonymous-complement? ] [ 2drop f ] } { [ over members ] [ left-union-class< ] } { [ dup anonymous-union? ] [ right-anonymous-union< ] } { [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] } + { [ over anonymous-complement? ] [ 2drop f ] } { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } { [ dup members ] [ right-union-class< ] } { [ over superclass ] [ superclass< ] } @@ -193,9 +193,8 @@ C: anonymous-complement [ ] unfold nip ; : min-class ( class seq -- class/f ) - [ dupd classes-intersect? ] subset dup empty? [ - 2drop f - ] [ + over [ classes-intersect? ] curry subset + dup empty? [ 2drop f ] [ tuck [ class< ] with all? [ peek ] [ drop f ] if ] if ; From 6dedc433d510d137db4af36b5ab7fe2860d667a9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 02:11:55 -0500 Subject: [PATCH 11/13] Improve recursive word type inference --- core/inference/backend/backend-docs.factor | 4 - core/inference/backend/backend.factor | 39 ++-- core/inference/class/class-tests.factor | 79 +++++++- core/inference/class/class.factor | 191 ++++++++++++-------- core/inference/dataflow/dataflow.factor | 5 +- core/optimizer/collect/collect.factor | 10 + core/optimizer/control/control-tests.factor | 32 ++-- core/optimizer/control/control.factor | 3 +- core/optimizer/def-use/def-use-tests.factor | 4 +- core/optimizer/def-use/def-use.factor | 50 ++--- core/optimizer/inlining/inlining.factor | 3 +- core/optimizer/math/math.factor | 75 +++----- core/optimizer/optimizer-tests.factor | 43 +---- core/optimizer/optimizer.factor | 11 +- 14 files changed, 317 insertions(+), 232 deletions(-) create mode 100644 core/optimizer/collect/collect.factor diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor index 0125f04efa..91314d1312 100755 --- a/core/inference/backend/backend-docs.factor +++ b/core/inference/backend/backend-docs.factor @@ -48,10 +48,6 @@ HELP: no-effect { $description "Throws a " { $link no-effect } " error." } { $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ; -HELP: collect-recursion -{ $values { "#label" "a " { $link #label } " node" } { "seq" "a new sequence" } } -{ $description "Collect the input stacks of all child " { $link #call-label } " nodes that call the given label." } ; - HELP: inline-word { $values { "word" word } } { $description "Called during inference to infer stack effects of inline words." diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index e0cc1a5839..f60748a5ac 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -409,6 +409,25 @@ TUPLE: recursive-declare-error word ; \ recursive-declare-error inference-error ] if* ; +GENERIC: collect-label-info* ( label node -- ) + +M: node collect-label-info* 2drop ; + +: (collect-label-info) ( label node vector -- ) + >r tuck [ param>> ] bi@ eq? r> [ push ] curry [ drop ] if ; + inline + +M: #call-label collect-label-info* + over calls>> (collect-label-info) ; + +M: #return collect-label-info* + over returns>> (collect-label-info) ; + +: collect-label-info ( #label -- ) + V{ } clone >>calls + V{ } clone >>returns + dup [ collect-label-info* ] with each-node ; + : nest-node ( -- ) #entry node, ; : unnest-node ( new-node -- new-node ) @@ -419,27 +438,17 @@ TUPLE: recursive-declare-error word ; : gensym dup t "inlined-block" set-word-prop ; -: inline-block ( word -- node-block data ) +: inline-block ( word -- #label data ) [ copy-inference nest-node dup word-def swap [ infer-quot-recursive ] 2keep #label unnest-node + dup collect-label-info ] H{ } make-assoc ; -GENERIC: collect-recursion* ( label node -- ) - -M: node collect-recursion* 2drop ; - -M: #call-label collect-recursion* - tuck node-param eq? [ , ] [ drop ] if ; - -: collect-recursion ( #label -- seq ) - dup node-param - [ [ swap collect-recursion* ] curry each-node ] { } make ; - -: join-values ( node -- ) - collect-recursion [ node-in-d ] map meta-d get suffix +: join-values ( #label -- ) + calls>> [ node-in-d ] map meta-d get suffix unify-lengths unify-stacks meta-d [ length tail* ] change ; @@ -460,7 +469,7 @@ M: #call-label collect-recursion* drop join-values inline-block apply-infer r> over set-node-in-d dup node, - collect-recursion [ + calls>> [ [ flatten-curries ] modify-values ] each ] [ diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index dcd83f7f7c..3f242261fd 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -4,7 +4,12 @@ inference.dataflow optimizer tools.test kernel.private generic sequences words inference.class quotations alien alien.c-types strings sbufs sequences.private slots.private combinators definitions compiler.units -system layouts vectors optimizer.math.partial ; +system layouts vectors optimizer.math.partial accessors +optimizer.inlining ; + +[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test + +[ f ] [ T{ literal-constraint f 1 3 } T{ literal-constraint f 1 2 } equal? ] unit-test ! Make sure these compile even though this is invalid code [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test @@ -268,19 +273,24 @@ M: float detect-float ; [ 3 + = ] \ equal? inlined? ] unit-test -[ t ] [ +[ f ] [ [ { fixnum fixnum } declare 7 bitand neg shift ] - \ shift inlined? + \ fixnum-shift-fast inlined? ] unit-test [ t ] [ [ { fixnum fixnum } declare 7 bitand neg shift ] - \ fixnum-shift inlined? + { shift fixnum-shift } inlined? ] unit-test [ t ] [ [ { fixnum fixnum } declare 1 swap 7 bitand shift ] - \ fixnum-shift inlined? + { shift fixnum-shift } inlined? +] unit-test + +[ f ] [ + [ { fixnum fixnum } declare 1 swap 7 bitand shift ] + { fixnum-shift-fast } inlined? ] unit-test cell-bits 32 = [ @@ -375,25 +385,78 @@ cell-bits 32 = [ [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? ] unit-test +: rec ( a -- b ) + dup 0 > [ 1 - rec ] when ; inline + +[ t ] [ + [ { fixnum } declare rec 1 + ] + { > - + } inlined? +] unit-test + : fib ( m -- n ) dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline [ t ] [ - [ 27.0 fib ] { < - } inlined? + [ 27.0 fib ] { < - + } inlined? +] unit-test + +[ f ] [ + [ 27.0 fib ] { +-integer-integer } inlined? ] unit-test [ t ] [ - [ 27 fib ] { < - } inlined? + [ 27 fib ] { < - + } inlined? ] unit-test [ t ] [ - [ 27 >bignum fib ] { < - } inlined? + [ 27 >bignum fib ] { < - + } inlined? ] unit-test [ f ] [ [ 27/2 fib ] { < - } inlined? ] unit-test +: hang-regression ( m n -- x ) + over 0 number= [ + nip + ] [ + dup [ + drop 1 hang-regression + ] [ + dupd hang-regression hang-regression + ] if + ] if ; inline + +[ t ] [ + [ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if +] { } inlined? ] unit-test + +: detect-null ( a -- b ) dup drop ; + +\ detect-null { + { [ dup dup in-d>> first node-class null eq? ] [ [ ] f splice-quot ] } +} define-optimizers + +[ t ] [ + [ { null } declare detect-null ] \ detect-null inlined? +] unit-test + +[ t ] [ + [ { null null } declare + detect-null ] \ detect-null inlined? +] unit-test + +[ f ] [ + [ { null fixnum } declare + detect-null ] \ detect-null inlined? +] unit-test + +GENERIC: detect-integer ( a -- b ) + +M: integer detect-integer ; + +[ t ] [ + [ { null fixnum } declare + detect-integer ] \ detect-integer inlined? +] unit-test + [ t ] [ [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined? ] unit-test diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 1c0f5a46e1..c2629f107f 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs hashtables inference kernel math namespaces sequences words parser math.intervals effects classes classes.algebra inference.dataflow -inference.backend combinators ; +inference.backend combinators accessors ; IN: inference.class ! Class inference @@ -25,12 +25,10 @@ C: literal-constraint M: literal-constraint equal? over literal-constraint? [ - 2dup - [ literal-constraint-literal ] bi@ eql? >r - [ literal-constraint-value ] bi@ = r> and - ] [ - 2drop f - ] if ; + [ [ literal>> ] bi@ eql? ] + [ [ value>> ] bi@ = ] + 2bi and + ] [ 2drop f ] if ; TUPLE: class-constraint class value ; @@ -43,8 +41,8 @@ C: interval-constraint GENERIC: apply-constraint ( constraint -- ) GENERIC: constraint-satisfied? ( constraint -- ? ) -: `input node get node-in-d nth ; -: `output node get node-out-d nth ; +: `input node get in-d>> nth ; +: `output node get out-d>> nth ; : class, , ; : literal, , ; : interval, , ; @@ -84,14 +82,12 @@ SYMBOL: value-classes set-value-interval* ; M: interval-constraint apply-constraint - dup interval-constraint-interval - swap interval-constraint-value intersect-value-interval ; + [ interval>> ] [ value>> ] bi intersect-value-interval ; : set-class-interval ( class value -- ) over class? [ - over "interval" word-prop [ - >r "interval" word-prop r> set-value-interval* - ] [ 2drop ] if + >r "interval" word-prop r> over + [ set-value-interval* ] [ 2drop ] if ] [ 2drop ] if ; : value-class* ( value -- class ) @@ -110,18 +106,21 @@ M: interval-constraint apply-constraint [ value-class* class-and ] keep set-value-class* ; M: class-constraint apply-constraint - dup class-constraint-class - swap class-constraint-value intersect-value-class ; + [ class>> ] [ value>> ] bi intersect-value-class ; + +: literal-interval ( value -- interval/f ) + dup real? [ [a,a] ] [ drop f ] if ; : set-value-literal* ( literal value -- ) - over class over set-value-class* - over real? [ over [a,a] over set-value-interval* ] when - 2dup assume - value-literals get set-at ; + { + [ >r class r> set-value-class* ] + [ >r literal-interval r> set-value-interval* ] + [ assume ] + [ value-literals get set-at ] + } 2cleave ; M: literal-constraint apply-constraint - dup literal-constraint-literal - swap literal-constraint-value set-value-literal* ; + [ literal>> ] [ value>> ] bi set-value-literal* ; ! For conditionals, an assoc of child node # --> constraint GENERIC: child-constraints ( node -- seq ) @@ -133,19 +132,18 @@ GENERIC: infer-classes-around ( node -- ) M: node infer-classes-before drop ; M: node child-constraints - node-children length + children>> length dup zero? [ drop f ] [ f ] if ; : value-literal* ( value -- obj ? ) value-literals get at* ; M: literal-constraint constraint-satisfied? - dup literal-constraint-value value-literal* - [ swap literal-constraint-literal eql? ] [ 2drop f ] if ; + dup value>> value-literal* + [ swap literal>> eql? ] [ 2drop f ] if ; M: class-constraint constraint-satisfied? - dup class-constraint-value value-class* - swap class-constraint-class class< ; + [ value>> value-class* ] [ class>> ] bi class< ; M: pair apply-constraint first2 2dup constraints get set-at @@ -154,19 +152,18 @@ M: pair apply-constraint M: pair constraint-satisfied? first constraint-satisfied? ; -: extract-keys ( assoc seq -- newassoc ) - dup length swap [ - dup >r pick at* [ r> pick set-at ] [ r> 2drop ] if - ] each nip f assoc-like ; +: extract-keys ( seq assoc -- newassoc ) + [ dupd at ] curry H{ } map>assoc [ nip ] assoc-subset f assoc-like ; : annotate-node ( node -- ) #! Annotate the node with the currently-inferred set of #! value classes. - dup node-values - value-intervals get over extract-keys pick set-node-intervals - value-classes get over extract-keys pick set-node-classes - value-literals get over extract-keys pick set-node-literals - 2drop ; + dup node-values { + [ value-intervals get extract-keys >>intervals ] + [ value-classes get extract-keys >>classes ] + [ value-literals get extract-keys >>literals ] + [ 2drop ] + } cleave ; : intersect-classes ( classes values -- ) [ intersect-value-class ] 2each ; @@ -190,31 +187,29 @@ M: pair constraint-satisfied? ] 2bi ; : compute-constraints ( #call -- ) - dup node-param "constraints" word-prop [ + dup param>> "constraints" word-prop [ call ] [ - dup node-param "predicating" word-prop dup + dup param>> "predicating" word-prop dup [ swap predicate-constraints ] [ 2drop ] if ] if* ; : compute-output-classes ( node word -- classes intervals ) - dup node-param "output-classes" word-prop + dup param>> "output-classes" word-prop dup [ call ] [ 2drop f f ] if ; : output-classes ( node -- classes intervals ) dup compute-output-classes >r - [ ] [ node-param "default-output-classes" word-prop ] ?if + [ ] [ param>> "default-output-classes" word-prop ] ?if r> ; M: #call infer-classes-before - dup compute-constraints - dup node-out-d swap output-classes - >r over intersect-classes - r> swap intersect-intervals ; + [ compute-constraints ] keep + [ output-classes ] [ out-d>> ] bi + tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ; M: #push infer-classes-before - node-out-d - [ [ value-literal ] keep set-value-literal* ] each ; + out-d>> [ [ value-literal ] keep set-value-literal* ] each ; M: #if child-constraints [ @@ -224,19 +219,17 @@ M: #if child-constraints M: #dispatch child-constraints dup [ - node-children length [ - 0 `input literal, - ] each + children>> length [ 0 `input literal, ] each ] make-constraints ; M: #declare infer-classes-before - dup node-param swap node-in-d + [ param>> ] [ in-d>> ] bi [ intersect-value-class ] 2each ; DEFER: (infer-classes) : infer-children ( node -- ) - dup node-children swap child-constraints [ + [ children>> ] [ child-constraints ] bi [ [ value-classes [ clone ] change value-literals [ clone ] change @@ -251,17 +244,21 @@ DEFER: (infer-classes) >r dup [ length ] map supremum r> [ pad-left ] 2curry map ; : (merge-classes) ( nodes -- seq ) - [ node-input-classes ] map - null pad-all flip [ null [ class-or ] reduce ] map ; + dup length 1 = [ + first node-input-classes + ] [ + [ node-input-classes ] map null pad-all flip + [ null [ class-or ] reduce ] map + ] if ; : set-classes ( seq node -- ) - node-out-d [ set-value-class* ] 2reverse-each ; + out-d>> [ set-value-class* ] 2reverse-each ; : merge-classes ( nodes node -- ) >r (merge-classes) r> set-classes ; : set-intervals ( seq node -- ) - node-out-d [ set-value-interval* ] 2reverse-each ; + out-d>> [ set-value-interval* ] 2reverse-each ; : merge-intervals ( nodes node -- ) >r @@ -276,28 +273,70 @@ DEFER: (infer-classes) dup node-successor dup #merge? [ swap active-children dup empty? [ 2drop ] [ swap annotate-merge ] if - ] [ - 2drop - ] if ; + ] [ 2drop ] if ; + +: classes= ( inferred current -- ? ) + 2dup min-length [ tail* ] curry bi@ sequence= ; + +SYMBOL: fixed-point? + +SYMBOL: nested-labels : annotate-entry ( nodes #label -- ) - node-child merge-classes ; + >r (merge-classes) r> node-child + 2dup node-output-classes classes= + [ 2drop ] [ set-classes fixed-point? off ] if ; + +: init-recursive-calls ( #label -- ) + #! We set recursive calls to output the empty type, then + #! repeat inference until a fixed point is reached. + #! Hopefully, our type functions are monotonic so this + #! will always converge. + returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ; M: #label infer-classes-before ( #label -- ) - #! First, infer types under the hypothesis which hold on - #! entry to the recursive label. - [ 1array ] keep annotate-entry ; + [ init-recursive-calls ] + [ [ 1array ] keep annotate-entry ] bi ; + +: infer-label-loop ( #label -- ) + fixed-point? on + dup node-child (infer-classes) + dup [ calls>> ] [ suffix ] [ annotate-entry ] tri + fixed-point? get [ drop ] [ infer-label-loop ] if ; M: #label infer-classes-around ( #label -- ) #! Now merge the types at every recursion point with the #! entry types. - { - [ annotate-node ] - [ infer-classes-before ] - [ infer-children ] - [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ] - [ node-child (infer-classes) ] - } cleave ; + [ + { + [ nested-labels get push ] + [ annotate-node ] + [ infer-classes-before ] + [ infer-label-loop ] + [ drop nested-labels get pop* ] + } cleave + ] with-scope ; + +: find-label ( param -- #label ) + param>> nested-labels get [ param>> eq? ] with find nip ; + +M: #call-label infer-classes-before ( #call-label -- ) + [ find-label returns>> (merge-classes) ] [ out-d>> ] bi + [ set-value-class* ] 2each ; + +M: #return infer-classes-around + nested-labels get length 0 > [ + dup param>> nested-labels get peek param>> eq? [ + [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri + classes= [ + drop + ] [ + fixed-point? off + [ in-d>> value-classes get extract-keys ] keep + set-node-classes + ] if + ] [ drop ] if + ] [ drop ] if ; M: object infer-classes-around { @@ -310,11 +349,13 @@ M: object infer-classes-around : (infer-classes) ( node -- ) [ [ infer-classes-around ] - [ node-successor (infer-classes) ] bi + [ node-successor ] bi + (infer-classes) ] when* ; : infer-classes-with ( node classes literals intervals -- ) [ + V{ } clone nested-labels set H{ } assoc-like value-intervals set H{ } assoc-like value-literals set H{ } assoc-like value-classes set @@ -322,13 +363,11 @@ M: object infer-classes-around (infer-classes) ] with-scope ; -: infer-classes ( node -- ) - f f f infer-classes-with ; +: infer-classes ( node -- node ) + dup f f f infer-classes-with ; : infer-classes/node ( node existing -- ) #! Infer classes, using the existing node's class info as a #! starting point. - dup node-classes - over node-literals - rot node-intervals + [ node-classes ] [ node-literals ] [ node-intervals ] tri infer-classes-with ; diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 3fb047b781..bb66a5386c 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -90,7 +90,7 @@ M: object flatten-curry , ; : node-child node-children first ; -TUPLE: #label < node word loop? ; +TUPLE: #label < node word loop? returns calls ; : #label ( word label -- node ) \ #label param-node swap >>word ; @@ -290,6 +290,9 @@ SYMBOL: node-stack : node-input-classes ( node -- seq ) dup in-d>> [ node-class ] with map ; +: node-output-classes ( node -- seq ) + dup out-d>> [ node-class ] with map ; + : node-input-intervals ( node -- seq ) dup in-d>> [ node-interval ] with map ; diff --git a/core/optimizer/collect/collect.factor b/core/optimizer/collect/collect.factor new file mode 100644 index 0000000000..6b9aee4e1a --- /dev/null +++ b/core/optimizer/collect/collect.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: inference.dataflow inference.backend kernel ; +IN: optimizer + +: collect-label-infos ( node -- node ) + dup [ + dup #label? [ collect-label-info ] [ drop ] if + ] each-node ; + diff --git a/core/optimizer/control/control-tests.factor b/core/optimizer/control/control-tests.factor index ce77cdd43a..9c6d041bca 100755 --- a/core/optimizer/control/control-tests.factor +++ b/core/optimizer/control/control-tests.factor @@ -27,22 +27,22 @@ optimizer ; dup [ 1+ loop-test-1 ] [ drop ] if ; inline [ t ] [ - [ loop-test-1 ] dataflow dup detect-loops + [ loop-test-1 ] dataflow detect-loops \ loop-test-1 label-is-loop? ] unit-test [ t ] [ - [ loop-test-1 1 2 3 ] dataflow dup detect-loops + [ loop-test-1 1 2 3 ] dataflow detect-loops \ loop-test-1 label-is-loop? ] unit-test [ t ] [ - [ [ loop-test-1 ] each ] dataflow dup detect-loops + [ [ loop-test-1 ] each ] dataflow detect-loops \ loop-test-1 label-is-loop? ] unit-test [ t ] [ - [ [ loop-test-1 ] each ] dataflow dup detect-loops + [ [ loop-test-1 ] each ] dataflow detect-loops \ (each-integer) label-is-loop? ] unit-test @@ -50,7 +50,7 @@ optimizer ; dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline [ t ] [ - [ loop-test-2 ] dataflow dup detect-loops + [ loop-test-2 ] dataflow detect-loops \ loop-test-2 label-is-not-loop? ] unit-test @@ -58,7 +58,7 @@ optimizer ; dup [ [ loop-test-3 ] each ] [ drop ] if ; inline [ t ] [ - [ loop-test-3 ] dataflow dup detect-loops + [ loop-test-3 ] dataflow detect-loops \ loop-test-3 label-is-not-loop? ] unit-test @@ -73,7 +73,7 @@ optimizer ; dup #label? [ node-successor find-label ] unless ; : test-loop-exits - dataflow dup detect-loops find-label + dataflow detect-loops find-label dup node-param swap [ node-child find-tail find-loop-exits [ class ] map ] keep #label-loop? ; @@ -113,7 +113,7 @@ optimizer ; ] unit-test [ f ] [ - [ [ [ ] map ] map ] dataflow dup detect-loops + [ [ [ ] map ] map ] dataflow detect-loops [ dup #label? swap #loop? not and ] node-exists? ] unit-test @@ -128,22 +128,22 @@ DEFER: a blah [ b ] [ a ] if ; inline [ t ] [ - [ a ] dataflow dup detect-loops + [ a ] dataflow detect-loops \ a label-is-loop? ] unit-test [ t ] [ - [ a ] dataflow dup detect-loops + [ a ] dataflow detect-loops \ b label-is-loop? ] unit-test [ t ] [ - [ b ] dataflow dup detect-loops + [ b ] dataflow detect-loops \ a label-is-loop? ] unit-test [ t ] [ - [ a ] dataflow dup detect-loops + [ a ] dataflow detect-loops \ b label-is-loop? ] unit-test @@ -156,12 +156,12 @@ DEFER: a' blah [ b' ] [ a' ] if ; inline [ f ] [ - [ a' ] dataflow dup detect-loops + [ a' ] dataflow detect-loops \ a' label-is-loop? ] unit-test [ f ] [ - [ b' ] dataflow dup detect-loops + [ b' ] dataflow detect-loops \ b' label-is-loop? ] unit-test @@ -171,11 +171,11 @@ DEFER: a' ! a standard iterative dataflow problem after all -- so I'm ! tempted to believe the computer here [ t ] [ - [ b' ] dataflow dup detect-loops + [ b' ] dataflow detect-loops \ a' label-is-loop? ] unit-test [ f ] [ - [ a' ] dataflow dup detect-loops + [ a' ] dataflow detect-loops \ b' label-is-loop? ] unit-test diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index f9f8901c41..976156db77 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -109,8 +109,9 @@ SYMBOL: potential-loops ] [ 2drop ] if ] assoc-each [ remove-non-loop-calls ] when ; -: detect-loops ( nodes -- ) +: detect-loops ( node -- node ) [ + dup collect-label-info remove-non-tail-calls remove-non-loop-calls diff --git a/core/optimizer/def-use/def-use-tests.factor b/core/optimizer/def-use/def-use-tests.factor index f22cce9fa8..914018437a 100755 --- a/core/optimizer/def-use/def-use-tests.factor +++ b/core/optimizer/def-use/def-use-tests.factor @@ -3,12 +3,12 @@ USING: inference inference.dataflow optimizer optimizer.def-use namespaces assocs kernel sequences math tools.test words ; [ 3 { 1 1 1 } ] [ - [ 1 2 3 ] dataflow compute-def-use + [ 1 2 3 ] dataflow compute-def-use drop def-use get values dup length swap [ length ] map ] unit-test : kill-set ( quot -- seq ) - dataflow compute-def-use compute-dead-literals keys + dataflow compute-def-use drop compute-dead-literals keys [ value-literal ] map ; : subset? [ member? ] curry all? ; diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor index 54fca38ee2..66bffd9767 100755 --- a/core/optimizer/def-use/def-use.factor +++ b/core/optimizer/def-use/def-use.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: optimizer.def-use USING: namespaces assocs sequences inference.dataflow -inference.backend kernel generic assocs classes vectors ; +inference.backend kernel generic assocs classes vectors +accessors combinators ; +IN: optimizer.def-use SYMBOL: def-use @@ -21,17 +22,20 @@ SYMBOL: def-use GENERIC: node-def-use ( node -- ) -: compute-def-use ( node -- ) - H{ } clone def-use set [ node-def-use ] each-node ; +: compute-def-use ( node -- node ) + H{ } clone def-use set + dup [ node-def-use ] each-node ; : nest-def-use ( node -- def-use ) - [ compute-def-use def-use get ] with-scope ; + [ compute-def-use drop def-use get ] with-scope ; : (node-def-use) ( node -- ) - dup dup node-in-d uses-values - dup dup node-in-r uses-values - dup node-out-d defs-values - node-out-r defs-values ; + { + [ dup in-d>> uses-values ] + [ dup in-r>> uses-values ] + [ out-d>> defs-values ] + [ out-r>> defs-values ] + } cleave ; M: object node-def-use (node-def-use) ; @@ -43,7 +47,7 @@ M: #passthru node-def-use drop ; M: #return node-def-use #! Values returned by local labels can be killed. - dup node-param [ drop ] [ (node-def-use) ] if ; + dup param>> [ drop ] [ (node-def-use) ] if ; ! nodes that don't use their values directly UNION: #killable @@ -56,13 +60,13 @@ UNION: #killable M: #label node-def-use [ - dup node-in-d , - dup node-child node-out-d , - dup collect-recursion [ node-in-d , ] each + dup in-d>> , + dup node-child out-d>> , + dup calls>> [ in-d>> , ] each ] { } make purge-invariants uses-values ; : branch-def-use ( #branch -- ) - active-children [ node-in-d ] map + active-children [ in-d>> ] map purge-invariants t swap uses-values ; M: #branch node-def-use @@ -85,16 +89,16 @@ M: node kill-node* drop t ; inline M: #shuffle kill-node* - [ - dup node-in-d empty? swap node-out-d empty? and - ] prune-if ; + [ [ in-d>> empty? ] [ out-d>> empty? ] bi and ] prune-if ; M: #push kill-node* - [ node-out-d empty? ] prune-if ; + [ out-d>> empty? ] prune-if ; -M: #>r kill-node* [ node-in-d empty? ] prune-if ; +M: #>r kill-node* + [ in-d>> empty? ] prune-if ; -M: #r> kill-node* [ node-in-r empty? ] prune-if ; +M: #r> kill-node* + [ in-r>> empty? ] prune-if ; : kill-node ( node -- node ) dup [ @@ -116,7 +120,7 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ; ] if ; : sole-consumer ( #call -- node/f ) - node-out-d first used-by + out-d>> first used-by dup length 1 = [ first ] [ drop f ] if ; : splice-def-use ( node -- ) @@ -128,5 +132,5 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ; #! degree of accuracy; the new values should be marked as #! having _some_ usage, so that flushing doesn't erronously #! flush them away. - [ compute-def-use def-use get keys ] with-scope + nest-def-use keys def-use get [ [ t swap ?push ] change-at ] curry each ; diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index e74e8b1de2..33c8244b4c 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -71,6 +71,7 @@ DEFER: (flat-length) ! Partial dispatch of math-generic words : normalize-math-class ( class -- class' ) { + null fixnum bignum integer ratio rational float real @@ -192,7 +193,7 @@ DEFER: (flat-length) nip dup [ second ] when ; : apply-identities ( node -- node/f ) - dup find-identity dup [ f splice-quot ] [ 2drop f ] if ; + dup find-identity f splice-quot ; : optimistic-inline? ( #call -- ? ) dup node-param "specializer" word-prop dup [ diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index fe33c57d42..c0191cf89d 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -8,7 +8,7 @@ namespaces assocs quotations math.intervals sequences.private combinators splitting layouts math.parser classes classes.algebra generic.math optimizer.pattern-match optimizer.backend optimizer.def-use optimizer.inlining -optimizer.math.partial generic.standard system ; +optimizer.math.partial generic.standard system accessors ; : define-math-identities ( word identities -- ) >r all-derived-ops r> define-identities ; @@ -95,22 +95,17 @@ optimizer.math.partial generic.standard system ; } define-math-identities : math-closure ( class -- newclass ) - { fixnum bignum integer rational float real number } + { null fixnum bignum integer rational float real number } [ class< ] with find nip number or ; : fits? ( interval class -- ? ) "interval" word-prop dup [ interval-subset? ] [ 2drop t ] if ; -: math-output-class ( node min -- newclass ) - #! if min is f, it means we just want to use the declared - #! output class from the "infer-effect". - dup [ - swap node-in-d - [ value-class* math-closure math-class-max ] each - ] [ - 2drop f - ] if ; +: math-output-class ( node upgrades -- newclass ) + >r + in-d>> null [ value-class* math-closure math-class-max ] reduce + dup r> at swap or ; : won't-overflow? ( interval node -- ? ) node-in-d [ value-class* fixnum class< ] all? @@ -129,22 +124,17 @@ optimizer.math.partial generic.standard system ; 2drop f ] if ; inline -: math-output-class/interval-1 ( node min word -- classes intervals ) - pick >r - >r over r> - math-output-interval-1 - >r math-output-class r> - r> post-process ; inline +: math-output-class/interval-1 ( node word -- classes intervals ) + [ drop { } math-output-class ] [ math-output-interval-1 ] 2bi ; { - { bitnot fixnum interval-bitnot } - { fixnum-bitnot f interval-bitnot } - { bignum-bitnot f interval-bitnot } + { bitnot interval-bitnot } + { fixnum-bitnot interval-bitnot } + { bignum-bitnot interval-bitnot } } [ - first3 [ - math-output-class/interval-1 - ] 2curry "output-classes" set-word-prop -] each + [ math-output-class/interval-1 ] curry + "output-classes" set-word-prop +] assoc-each : intervals ( node -- i1 i2 ) node-in-d first2 [ value-interval* ] bi@ ; @@ -156,7 +146,7 @@ optimizer.math.partial generic.standard system ; 2drop f ] if ; inline -: math-output-class/interval-2 ( node min word -- classes intervals ) +: math-output-class/interval-2 ( node upgrades word -- classes intervals ) pick >r >r over r> math-output-interval-2 @@ -164,12 +154,12 @@ optimizer.math.partial generic.standard system ; r> post-process ; inline { - { + integer interval+ } - { - integer interval- } - { * integer interval* } - { / rational interval/ } - { /i integer interval/i } - { shift f interval-shift-safe } + { + { { fixnum integer } } interval+ } + { - { { fixnum integer } } interval- } + { * { { fixnum integer } } interval* } + { / { { fixnum rational } { integer rational } } interval/ } + { /i { { fixnum integer } } interval/i } + { shift { { fixnum integer } } interval-shift-safe } } [ first3 [ [ @@ -178,16 +168,6 @@ optimizer.math.partial generic.standard system ; ] 2curry each-derived-op ] each -\ shift [ - [ - dup - node-in-d second value-interval* - -1./0. 0 [a,b] interval-subset? fixnum integer ? - \ interval-shift-safe - math-output-class/interval-2 - ] "output-classes" set-word-prop -] each-derived-op - : real-value? ( value -- n ? ) dup value? [ value-literal dup real? ] [ drop f f ] if ; @@ -216,12 +196,12 @@ optimizer.math.partial generic.standard system ; r> post-process ; inline { - { mod fixnum mod-range } - { rem integer rem-range } + { mod { } mod-range } + { rem { { fixnum integer } } rem-range } - { bitand fixnum bitand-range } - { bitor fixnum f } - { bitxor fixnum f } + { bitand { } bitand-range } + { bitor { } f } + { bitxor { } f } } [ first3 [ [ @@ -311,7 +291,8 @@ most-negative-fixnum most-positive-fixnum [a,b] ! Removing overflow checks : remove-overflow-check? ( #call -- ? ) - dup node-out-d first node-class fixnum class< ; + dup out-d>> first node-class + [ fixnum class< ] [ null eq? not ] bi and ; { { + [ fixnum+fast ] } diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 1a48e353a2..63a63a2f92 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -14,40 +14,6 @@ IN: optimizer.tests H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* ] unit-test -! Test method inlining -[ f ] [ fixnum { } min-class ] unit-test - -[ string ] [ - \ string - [ integer string array reversed sbuf - slice vector quotation ] - sort-classes min-class -] unit-test - -[ fixnum ] [ - \ fixnum - [ fixnum integer object ] - sort-classes min-class -] unit-test - -[ integer ] [ - \ fixnum - [ integer float object ] - sort-classes min-class -] unit-test - -[ object ] [ - \ word - [ integer float object ] - sort-classes min-class -] unit-test - -[ reversed ] [ - \ reversed - [ integer reversed slice ] - sort-classes min-class -] unit-test - GENERIC: xyz ( obj -- obj ) M: array xyz xyz ; @@ -374,3 +340,12 @@ HINTS: recursive-inline-hang-3 array ; USE: sequences.private [ ] [ { (3append) } compile ] unit-test + +! Wow +: counter-example ( a b c d -- a' b' c' d' ) + dup 0 > [ 1 - >r rot 2 * r> counter-example ] when ; inline + +: counter-example' ( -- a' b' c' d' ) + 1 2 3.0 3 counter-example ; + +[ 2 4 6.0 0 ] [ counter-example' ] unit-test diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor index 9e898450cc..23cba3ea4c 100755 --- a/core/optimizer/optimizer.factor +++ b/core/optimizer/optimizer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces optimizer.backend optimizer.def-use optimizer.known-words optimizer.math optimizer.control -optimizer.inlining inference.class ; +optimizer.collect optimizer.inlining inference.class ; IN: optimizer : optimize-1 ( node -- newnode ? ) @@ -10,10 +10,13 @@ IN: optimizer H{ } clone class-substitutions set H{ } clone literal-substitutions set H{ } clone value-substitutions set - dup compute-def-use + + collect-label-infos + compute-def-use kill-values - dup detect-loops - dup infer-classes + detect-loops + infer-classes + optimizer-changed off optimize-nodes optimizer-changed get From f48d5091c96ee8e218da75bd9ce9c02daa6841b9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 04:52:34 -0500 Subject: [PATCH 12/13] Faster inline allocators --- core/cpu/architecture/architecture.factor | 3 +++ core/cpu/ppc/allot/allot.factor | 15 ++++++++++++++- core/cpu/x86/32/32.factor | 2 ++ core/cpu/x86/64/64.factor | 2 ++ core/cpu/x86/allot/allot.factor | 19 ++++++++++++++++--- core/cpu/x86/architecture/architecture.factor | 4 ++++ core/generator/registers/registers.factor | 5 ----- core/inference/class/class-tests.factor | 10 ++++++++++ core/math/math.factor | 2 +- core/optimizer/math/math.factor | 4 ++-- vm/data_gc.c | 19 +++++++++---------- vm/data_gc.h | 15 ++++++++------- vm/debug.c | 6 +++++- vm/errors.c | 2 +- 14 files changed, 77 insertions(+), 31 deletions(-) diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 8c9db6c7e8..4e939bddb8 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -187,6 +187,9 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- ) HOOK: %box-alien cpu ( dst src -- ) +! GC check +HOOK: %gc cpu + : operand ( var -- op ) get v>operand ; inline : unique-operands ( operands quot -- ) diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor index 34ea82dc4e..47dc6b1570 100755 --- a/core/cpu/ppc/allot/allot.factor +++ b/core/cpu/ppc/allot/allot.factor @@ -7,7 +7,7 @@ cpu.architecture alien ; IN: cpu.ppc.allot : load-zone-ptr ( reg -- ) - "nursery" f pick %load-dlsym dup 0 LWZ ; + "nursery" f pick %load-dlsym ; : %allot ( header size -- ) #! Store a pointer to 'size' bytes allocated from the @@ -25,6 +25,19 @@ IN: cpu.ppc.allot : %store-tagged ( reg tag -- ) >r dup fresh-object v>operand 11 r> tag-number ORI ; +M: ppc %gc + "end" define-label + 12 load-zone-ptr + 11 12 cell LWZ ! nursery.here -> r11 + 12 12 3 cells LWZ ! nursery.end -> r12 + 11 12 1024 ADDI ! add ALLOT_BUFFER_ZONE to here + 0 11 12 CMPI ! is here >= end? + "end" get BLE + 0 frame-required + %prepare-alien-invoke + "minor_gc" f %alien-invoke + "end" resolve-label ; + : %allot-float ( reg -- ) #! exits with tagged ptr to object in r12, untagged in r11 float 16 %allot diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 985f717035..50e38f2082 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -17,6 +17,8 @@ M: x86.32 ds-reg ESI ; M: x86.32 rs-reg EDI ; M: x86.32 stack-reg ESP ; M: x86.32 stack-save-reg EDX ; +M: x86.32 temp-reg-1 EAX ; +M: x86.32 temp-reg-2 ECX ; M: temp-reg v>operand drop EBX ; diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 99f567f448..d79ce58d88 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -12,6 +12,8 @@ M: x86.64 ds-reg R14 ; M: x86.64 rs-reg R15 ; M: x86.64 stack-reg RSP ; M: x86.64 stack-save-reg RSI ; +M: x86.64 temp-reg-1 RAX ; +M: x86.64 temp-reg-2 RCX ; M: temp-reg v>operand drop RBX ; diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor index f236cdcfa6..bfcede7ef7 100755 --- a/core/cpu/x86/allot/allot.factor +++ b/core/cpu/x86/allot/allot.factor @@ -16,12 +16,12 @@ IN: cpu.x86.allot : object@ ( n -- operand ) cells (object@) ; -: load-zone-ptr ( -- ) +: load-zone-ptr ( reg -- ) #! Load pointer to start of zone array - "nursery" f allot-reg %alien-global ; + 0 MOV "nursery" f rc-absolute-cell rel-dlsym ; : load-allot-ptr ( -- ) - load-zone-ptr + allot-reg load-zone-ptr allot-reg PUSH allot-reg dup cell [+] MOV ; @@ -29,6 +29,19 @@ IN: cpu.x86.allot allot-reg POP allot-reg cell [+] swap 8 align ADD ; +M: x86.32 %gc ( -- ) + "end" define-label + temp-reg-1 load-zone-ptr + temp-reg-2 temp-reg-1 cell [+] MOV + temp-reg-2 1024 ADD + temp-reg-1 temp-reg-1 3 cells [+] MOV + temp-reg-2 temp-reg-1 CMP + "end" get JLE + 0 frame-required + %prepare-alien-invoke + "minor_gc" f %alien-invoke + "end" resolve-label ; + : store-header ( header -- ) 0 object@ swap type-number tag-fixnum MOV ; diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index fa1c9c8768..7e7ff8a334 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -34,6 +34,10 @@ GENERIC: push-return-reg ( reg-class -- ) GENERIC: load-return-reg ( stack@ reg-class -- ) GENERIC: store-return-reg ( stack@ reg-class -- ) +! Only used by inline allocation +HOOK: temp-reg-1 cpu +HOOK: temp-reg-2 cpu + HOOK: address-operand cpu ( address -- operand ) HOOK: fixnum>slot@ cpu diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 3b5b6ad096..a3198784ee 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -468,11 +468,6 @@ M: loc lazy-store : finalize-contents ( -- ) finalize-locs finalize-vregs reset-phantoms ; -: %gc ( -- ) - 0 frame-required - %prepare-alien-invoke - "simple_gc" f %alien-invoke ; - ! Loading stacks to vregs : free-vregs? ( int# float# -- ? ) double-float-regs free-vregs length <= diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 3f242261fd..0c4ff82798 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -305,6 +305,11 @@ cell-bits 32 = [ ] unit-test ] when +[ f ] [ + [ { integer } declare -63 shift 4095 bitand ] + \ shift inlined? +] unit-test + [ t ] [ [ B{ 1 0 } *short 0 number= ] \ number= inlined? @@ -557,6 +562,11 @@ M: integer detect-integer ; ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined? ] unit-test +[ t ] [ + [ { integer } declare bitnot detect-integer ] + \ detect-integer inlined? +] unit-test + ! Later ! [ t ] [ diff --git a/core/math/math.factor b/core/math/math.factor index 6a56baea3a..14cbe68351 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -122,7 +122,7 @@ M: float fp-nan? : next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable : power-of-2? ( n -- ? ) - dup 0 < [ drop f ] [ dup 1- bitand zero? ] if ; foldable + dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable : align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index c0191cf89d..ab8a1f3eda 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -125,7 +125,8 @@ optimizer.math.partial generic.standard system accessors ; ] if ; inline : math-output-class/interval-1 ( node word -- classes intervals ) - [ drop { } math-output-class ] [ math-output-interval-1 ] 2bi ; + [ drop { } math-output-class 1array ] + [ math-output-interval-1 1array ] 2bi ; { { bitnot interval-bitnot } @@ -362,7 +363,6 @@ most-negative-fixnum most-positive-fixnum [a,b] { + [ [ >fixnum ] bi@ fixnum+fast ] } { - [ [ >fixnum ] bi@ fixnum-fast ] } { * [ [ >fixnum ] bi@ fixnum*fast ] } - { shift [ [ >fixnum ] bi@ fixnum-shift-fast ] } } [ >r derived-ops r> [ [ diff --git a/vm/data_gc.c b/vm/data_gc.c index 86552d6401..5aa47c8c6c 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -122,7 +122,7 @@ void clear_cards(CELL from, CELL to) void set_data_heap(F_DATA_HEAP *data_heap_) { data_heap = data_heap_; - nursery = &data_heap->generations[NURSERY]; + nursery = data_heap->generations[NURSERY]; init_cards_offset(); clear_cards(NURSERY,TENURED); } @@ -231,7 +231,7 @@ DEFINE_PRIMITIVE(data_room) for(gen = 0; gen < data_heap->gen_count; gen++) { - F_ZONE *z = &data_heap->generations[gen]; + F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]); set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10)); set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10)); } @@ -583,7 +583,7 @@ CELL collect_next(CELL scan) INLINE void reset_generation(CELL i) { - F_ZONE *z = &data_heap->generations[i]; + F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]); z->here = z->start; if(secure_gc) memset((void*)z->start,69,z->size); @@ -608,7 +608,7 @@ void begin_gc(CELL requested_bytes) old_data_heap = data_heap; set_data_heap(grow_data_heap(old_data_heap,requested_bytes)); - newspace = &data_heap->generations[collecting_gen]; + newspace = &data_heap->generations[TENURED]; } else if(collecting_accumulation_gen_p()) { @@ -783,6 +783,11 @@ void gc(void) garbage_collection(TENURED,false,0); } +void minor_gc(void) +{ + garbage_collection(NURSERY,false,0); +} + DEFINE_PRIMITIVE(gc) { gc(); @@ -794,12 +799,6 @@ DEFINE_PRIMITIVE(gc_time) box_unsigned_8(gc_time); } -void simple_gc(void) -{ - if(nursery->here + ALLOT_BUFFER_ZONE > nursery->end) - garbage_collection(NURSERY,false,0); -} - DEFINE_PRIMITIVE(become) { F_ARRAY *new_objects = untag_array(dpop()); diff --git a/vm/data_gc.h b/vm/data_gc.h index 2490ed8805..be9ed159b7 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -20,6 +20,7 @@ DECLARE_PRIMITIVE(next_object); DECLARE_PRIMITIVE(end_scan); void gc(void); +DLLEXPORT void minor_gc(void); /* generational copying GC divides memory into zones */ typedef struct { @@ -125,7 +126,7 @@ void collect_cards(void); F_ZONE *newspace; /* new objects are allocated here */ -DLLEXPORT F_ZONE *nursery; +DLLEXPORT F_ZONE nursery; INLINE bool in_zone(F_ZONE *z, CELL pointer) { @@ -200,7 +201,7 @@ INLINE bool should_copy(CELL untagged) else if(HAVE_AGING_P && collecting_gen == AGING) return !in_zone(&data_heap->generations[TENURED],untagged); else if(HAVE_NURSERY_P && collecting_gen == NURSERY) - return in_zone(&data_heap->generations[NURSERY],untagged); + return in_zone(&nursery,untagged); else { critical_error("Bug in should_copy",untagged); @@ -315,13 +316,15 @@ INLINE void* allot_object(CELL type, CELL a) { CELL *object; - if(HAVE_NURSERY_P && nursery->size - ALLOT_BUFFER_ZONE > a) + if(HAVE_NURSERY_P && nursery.size - ALLOT_BUFFER_ZONE > a) { /* If there is insufficient room, collect the nursery */ - if(nursery->here + ALLOT_BUFFER_ZONE + a > nursery->end) + if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end) garbage_collection(NURSERY,false,0); - object = allot_zone(nursery,a); + CELL h = nursery.here; + nursery.here = h + align8(a); + object = (void*)h; } /* If the object is bigger than the nursery, allocate it in tenured space */ @@ -360,8 +363,6 @@ INLINE void* allot_object(CELL type, CELL a) CELL collect_next(CELL scan); -DLLEXPORT void simple_gc(void); - DECLARE_PRIMITIVE(gc); DECLARE_PRIMITIVE(gc_time); DECLARE_PRIMITIVE(become); diff --git a/vm/debug.c b/vm/debug.c index 840d252769..b86ec808bc 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -227,7 +227,11 @@ void dump_zone(F_ZONE *z) void dump_generations(void) { int i; - for(i = 0; i < data_heap->gen_count; i++) + + printf("Nursery: "); + dump_zone(&nursery); + + for(i = 1; i < data_heap->gen_count; i++) { printf("Generation %d: ",i); dump_zone(&data_heap->generations[i]); diff --git a/vm/errors.c b/vm/errors.c index 6d99d34766..57dc8b66a1 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -96,7 +96,7 @@ void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack) general_error(ERROR_RS_UNDERFLOW,F,F,native_stack); else if(in_page(addr, rs_bot, rs_size, 0)) general_error(ERROR_RS_OVERFLOW,F,F,native_stack); - else if(in_page(addr, nursery->end, 0, 0)) + else if(in_page(addr, nursery.end, 0, 0)) critical_error("allot_object() missed GC check",0); else if(in_page(addr, gc_locals_region->start, 0, -1)) critical_error("gc locals underflow",0); From 7faa9a831284d4ff18c8a21680f95b40d34ee4fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Apr 2008 04:52:50 -0500 Subject: [PATCH 13/13] Oops --- extra/project-euler/150/150.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index 5d83f5a732..c96c1ebc73 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -31,7 +31,7 @@ IN: project-euler.150 : sums-triangle ( -- seq ) 0 1000 [ 1+ [ next ] generate partial-sums ] map nip ; -PRIVATE> USING: arrays kernel.private ; +PRIVATE> :: (euler150) ( m -- n ) [let | table [ sums-triangle ] |