From 59091c6cf286764b4d94b1e18bd90e98f19b83d6 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 21 Jul 2009 17:09:32 +1200 Subject: [PATCH 01/52] alien.marshall: refactored unmarshalling words --- extra/alien/marshall/marshall-docs.factor | 2 +- extra/alien/marshall/marshall.factor | 65 +++++++++++++++-------- 2 files changed, 43 insertions(+), 24 deletions(-) diff --git a/extra/alien/marshall/marshall-docs.factor b/extra/alien/marshall/marshall-docs.factor index 6002b0c1c3..deac9fd186 100644 --- a/extra/alien/marshall/marshall-docs.factor +++ b/extra/alien/marshall/marshall-docs.factor @@ -327,7 +327,7 @@ HELP: out-arg-unmarshaller "for all types except pointers to non-const primitives." } ; -HELP: pointer-unmarshaller +HELP: class-unmarshaller { $values { "type" " a C type string" } { "quot" quotation } diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor index 85b157e4a0..deef94dc9b 100644 --- a/extra/alien/marshall/marshall.factor +++ b/extra/alien/marshall/marshall.factor @@ -11,7 +11,8 @@ specialized-arrays.long specialized-arrays.longlong specialized-arrays.short specialized-arrays.uchar specialized-arrays.uint specialized-arrays.ulong specialized-arrays.ulonglong specialized-arrays.ushort strings -unix.utilities vocabs.parser words libc.private struct-arrays ; +unix.utilities vocabs.parser words libc.private struct-arrays +locals generalizations ; IN: alien.marshall << primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ] @@ -269,33 +270,51 @@ ALIAS: marshall-void* marshall-pointer : ?malloc-byte-array ( c-type -- alien ) dup alien? [ malloc-byte-array ] unless ; -: struct-unmarshaller ( type -- quot ) - current-vocab lookup [ - dup superclasses [ \ struct-wrapper = ] any? [ - '[ ?malloc-byte-array _ new swap >>underlying ] - ] [ drop [ ] ] if - ] [ [ ] ] if* ; +:: x-unmarshaller ( type type-quot wrapper-test def clean -- quot/f ) + type type-quot call current-vocab lookup [ + dup superclasses wrapper-test any? + [ def call ] [ drop clean call f ] if + ] [ clean call f ] if* ; inline -: pointer-unmarshaller ( type -- quot ) - type-sans-pointer current-vocab lookup [ - dup superclasses [ \ alien-wrapper = ] any? [ - '[ _ new swap >>underlying unmarshall-cast ] - ] [ drop [ ] ] if - ] [ [ ] ] if* ; +: struct-unmarshaller ( type -- quot/f ) + [ ] [ \ struct-wrapper = ] + [ '[ ?malloc-byte-array _ new swap >>underlying ] ] + [ ] + x-unmarshaller ; + +: class-unmarshaller ( type -- quot/f ) + [ type-sans-pointer ] [ \ alien-wrapper = ] + [ '[ ?malloc-byte-array _ new swap >>underlying ] ] + [ ] + x-unmarshaller ; + +: template-class-unmarshaller ( type -- quot/f ) + [ parse-c++-type [ name>> ] keep swap ] [ \ template-wrapper = ] + [ '[ _ _ new swap >>type swap >>underlying unmarshall-cast ] ] + [ drop ] + x-unmarshaller ; + +: non-primitive-unmarshaller ( type -- quot/f ) + { + { [ dup template-class? ] + [ template-class-unmarshaller ] } + { [ dup pointer? ] [ class-unmarshaller ] } + [ struct-unmarshaller ] + } cond ; : unmarshaller ( type -- quot ) - factorize-type dup primitive-unmarshaller [ nip ] [ - dup pointer? - [ pointer-unmarshaller ] - [ struct-unmarshaller ] if - ] if* ; + factorize-type { + [ primitive-unmarshaller ] + [ non-primitive-unmarshaller ] + [ drop [ ] ] + } 1|| ; : struct-field-unmarshaller ( type -- quot ) - factorize-type dup struct-primitive-unmarshaller [ nip ] [ - dup pointer? - [ pointer-unmarshaller ] - [ struct-unmarshaller ] if - ] if* ; + factorize-type { + [ struct-primitive-unmarshaller ] + [ non-primitive-unmarshaller ] + [ drop [ ] ] + } 1|| ; : out-arg-unmarshaller ( type -- quot ) dup pointer-to-non-const-primitive? From c780bb724d368a3e9cb82667efbb26089f2e27ad Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 22 Jul 2009 12:25:45 +1200 Subject: [PATCH 02/52] alien.marshall: C++ type parsing --- extra/alien/inline/types/types.factor | 44 ++++++++++++++++++++++++++- extra/alien/marshall/marshall.factor | 13 +++----- 2 files changed, 47 insertions(+), 10 deletions(-) diff --git a/extra/alien/inline/types/types.factor b/extra/alien/inline/types/types.factor index 94b98d1eb5..fe4f6a4180 100644 --- a/extra/alien/inline/types/types.factor +++ b/extra/alien/inline/types/types.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types assocs combinators.short-circuit continuations effects fry kernel math memoize sequences -splitting ; +splitting strings peg.ebnf make alien.c-types ; IN: alien.inline.types : cify-type ( str -- str' ) @@ -21,6 +21,9 @@ IN: alien.inline.types : pointer-to-const? ( str -- ? ) cify-type "const " head? ; +: template-class? ( str -- ? ) + [ CHAR: < = ] any? ; + MEMO: resolved-primitives ( -- seq ) primitive-types [ resolve-typedef ] map ; @@ -57,3 +60,42 @@ MEMO: resolved-primitives ( -- seq ) [ over pointer-to-primitive? [ ">" prepend ] when ] assoc-map unzip ] dip ; + +TUPLE: c++-type name params ptr ; +C: c++-type + +EBNF: (parse-c++-type) +dig = [0-9] +alpha = [a-zA-Z] +alphanum = [1-9a-zA-Z] +name = [_a-zA-Z] [_a-zA-Z1-9]* => [[ first2 swap prefix >string ]] +ptr = [*&] => [[ empty? not ]] + +param = "," " "* type " "* => [[ third ]] + +params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]] + +type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 ]] +;EBNF + +: parse-c++-type ( str -- c++-type ) + factorize-type parse-c++-type ; + +DEFER: c++-type>string + +: params>string ( params -- str ) + [ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ; + +: c++-type>string ( c++-type -- str ) + [ + [ name>> % ] + [ params>> [ params>string % ] when* ] + [ ptr>> [ "*" % ] when ] + tri + ] "" make ; + +GENERIC: c++-type ( obj -- c++-type/f ) + +M: object c++-type drop f ; + +M: c++-type c-type ; diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor index deef94dc9b..2aede320aa 100644 --- a/extra/alien/marshall/marshall.factor +++ b/extra/alien/marshall/marshall.factor @@ -12,7 +12,7 @@ specialized-arrays.short specialized-arrays.uchar specialized-arrays.uint specialized-arrays.ulong specialized-arrays.ulonglong specialized-arrays.ushort strings unix.utilities vocabs.parser words libc.private struct-arrays -locals generalizations ; +locals generalizations math ; IN: alien.marshall << primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ] @@ -20,6 +20,7 @@ filter [ define-primitive-marshallers ] each >> TUPLE: alien-wrapper { underlying alien } ; TUPLE: struct-wrapper < alien-wrapper disposed ; +TUPLE: class-wrapper < alien-wrapper disposed ; GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' ) @@ -28,6 +29,8 @@ M: struct-wrapper unmarshall-cast ; M: struct-wrapper dispose* underlying>> free ; +M: class-wrapper c++-type class name>> parse-c++-type ; + : marshall-pointer ( obj -- alien ) { { [ dup alien? ] [ ] } @@ -288,16 +291,8 @@ ALIAS: marshall-void* marshall-pointer [ ] x-unmarshaller ; -: template-class-unmarshaller ( type -- quot/f ) - [ parse-c++-type [ name>> ] keep swap ] [ \ template-wrapper = ] - [ '[ _ _ new swap >>type swap >>underlying unmarshall-cast ] ] - [ drop ] - x-unmarshaller ; - : non-primitive-unmarshaller ( type -- quot/f ) { - { [ dup template-class? ] - [ template-class-unmarshaller ] } { [ dup pointer? ] [ class-unmarshaller ] } [ struct-unmarshaller ] } cond ; From 8ae1fb66a3d9c6abf5ab16cfa882566c07acd2c8 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 22 Jul 2009 15:57:29 +1200 Subject: [PATCH 03/52] alien.inline.types: fix parse-c++-type --- extra/alien/inline/types/types.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/alien/inline/types/types.factor b/extra/alien/inline/types/types.factor index fe4f6a4180..34162f422e 100644 --- a/extra/alien/inline/types/types.factor +++ b/extra/alien/inline/types/types.factor @@ -68,7 +68,7 @@ EBNF: (parse-c++-type) dig = [0-9] alpha = [a-zA-Z] alphanum = [1-9a-zA-Z] -name = [_a-zA-Z] [_a-zA-Z1-9]* => [[ first2 swap prefix >string ]] +name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]] ptr = [*&] => [[ empty? not ]] param = "," " "* type " "* => [[ third ]] @@ -79,7 +79,7 @@ type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 ;EBNF : parse-c++-type ( str -- c++-type ) - factorize-type parse-c++-type ; + factorize-type (parse-c++-type) ; DEFER: c++-type>string From 186cc7edb3476dd65351de484aca24932d58d8d5 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 22 Jul 2009 16:00:38 +1200 Subject: [PATCH 04/52] added alien.cxx --- extra/alien/cxx/authors.txt | 1 + extra/alien/cxx/cxx.factor | 22 ++++++++++++++++++++ extra/alien/cxx/parser/authors.txt | 1 + extra/alien/cxx/parser/parser.factor | 7 +++++++ extra/alien/cxx/syntax/authors.txt | 1 + extra/alien/cxx/syntax/syntax-tests.factor | 24 ++++++++++++++++++++++ extra/alien/cxx/syntax/syntax.factor | 6 ++++++ extra/alien/marshall/marshall.factor | 2 ++ 8 files changed, 64 insertions(+) create mode 100644 extra/alien/cxx/authors.txt create mode 100644 extra/alien/cxx/cxx.factor create mode 100644 extra/alien/cxx/parser/authors.txt create mode 100644 extra/alien/cxx/parser/parser.factor create mode 100644 extra/alien/cxx/syntax/authors.txt create mode 100644 extra/alien/cxx/syntax/syntax-tests.factor create mode 100644 extra/alien/cxx/syntax/syntax.factor diff --git a/extra/alien/cxx/authors.txt b/extra/alien/cxx/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/extra/alien/cxx/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/extra/alien/cxx/cxx.factor b/extra/alien/cxx/cxx.factor new file mode 100644 index 0000000000..71144e6450 --- /dev/null +++ b/extra/alien/cxx/cxx.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types alien.cxx.parser alien.marshall +alien.inline.types classes.mixin classes.tuple kernel namespaces +assocs sequences parser classes.parser ; +IN: alien.cxx + + + +: define-c++-class ( str superclass-mixin -- ) + [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip + add-mixin-instance define-class-tuple ; diff --git a/extra/alien/cxx/parser/authors.txt b/extra/alien/cxx/parser/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/extra/alien/cxx/parser/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/extra/alien/cxx/parser/parser.factor b/extra/alien/cxx/parser/parser.factor new file mode 100644 index 0000000000..4614a4a7b5 --- /dev/null +++ b/extra/alien/cxx/parser/parser.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: parser lexer ; +IN: alien.cxx.parser + +: parse-c++-class-definition ( -- class superclass-mixin ) + scan scan-word ; diff --git a/extra/alien/cxx/syntax/authors.txt b/extra/alien/cxx/syntax/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/extra/alien/cxx/syntax/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/extra/alien/cxx/syntax/syntax-tests.factor b/extra/alien/cxx/syntax/syntax-tests.factor new file mode 100644 index 0000000000..f9fb9a218f --- /dev/null +++ b/extra/alien/cxx/syntax/syntax-tests.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test alien.cxx.syntax alien.inline.syntax +alien.marshall.syntax alien.marshall ; +IN: alien.cxx.syntax.tests + +DELETE-C-LIBRARY: test +C-LIBRARY: test + +COMPILE-AS-C++ + +C-INCLUDE: + +C-TYPEDEF: std::string string + +C++-CLASS: std::string c++-root + +CM-FUNCTION: std::string* new_string ( const-char* s ) + return new std::string(s); +; + +;C-LIBRARY + +{ 1 1 } [ new_string ] must-infer-as diff --git a/extra/alien/cxx/syntax/syntax.factor b/extra/alien/cxx/syntax/syntax.factor new file mode 100644 index 0000000000..741950f79b --- /dev/null +++ b/extra/alien/cxx/syntax/syntax.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.cxx alien.cxx.parser ; +IN: alien.cxx.syntax + +SYNTAX: C++-CLASS: parse-c++-class-definition define-c++-class ; diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor index 2aede320aa..eec0cadcbb 100644 --- a/extra/alien/marshall/marshall.factor +++ b/extra/alien/marshall/marshall.factor @@ -22,6 +22,8 @@ TUPLE: alien-wrapper { underlying alien } ; TUPLE: struct-wrapper < alien-wrapper disposed ; TUPLE: class-wrapper < alien-wrapper disposed ; +MIXIN: c++-root + GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' ) M: alien-wrapper unmarshall-cast ; From 1218d3fa9d28e5ec4098f2cae7268d24a6ebccea Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 22 Jul 2009 17:21:07 +1200 Subject: [PATCH 05/52] alien.cxx: C++ methods --- extra/alien/cxx/cxx.factor | 12 ++++++++++-- extra/alien/cxx/parser/parser.factor | 5 ++++- extra/alien/cxx/syntax/syntax-tests.factor | 8 ++++++++ extra/alien/cxx/syntax/syntax.factor | 6 +++++- 4 files changed, 27 insertions(+), 4 deletions(-) diff --git a/extra/alien/cxx/cxx.factor b/extra/alien/cxx/cxx.factor index 71144e6450..ab7ff416fa 100644 --- a/extra/alien/cxx/cxx.factor +++ b/extra/alien/cxx/cxx.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.cxx.parser alien.marshall alien.inline.types classes.mixin classes.tuple kernel namespaces -assocs sequences parser classes.parser ; +assocs sequences parser classes.parser alien.marshall.syntax +interpolate locals effects io strings ; IN: alien.cxx -: define-c++-class ( str superclass-mixin -- ) +: define-c++-class ( name superclass-mixin -- ) [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip add-mixin-instance define-class-tuple ; + +:: define-c++-method ( class-name name types effect -- ) + effect [ in>> "self" suffix ] [ out>> ] bi :> effect' + types class-name "*" append suffix :> types' + effect in>> "," join :> args + SBUF" " dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body + name types' effect' body define-c-marshalled ; diff --git a/extra/alien/cxx/parser/parser.factor b/extra/alien/cxx/parser/parser.factor index 4614a4a7b5..84425649da 100644 --- a/extra/alien/cxx/parser/parser.factor +++ b/extra/alien/cxx/parser/parser.factor @@ -1,7 +1,10 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. -USING: parser lexer ; +USING: parser lexer alien.inline ; IN: alien.cxx.parser : parse-c++-class-definition ( -- class superclass-mixin ) scan scan-word ; + +: parse-c++-method-definition ( -- class-name name types effect ) + scan function-types-effect ; diff --git a/extra/alien/cxx/syntax/syntax-tests.factor b/extra/alien/cxx/syntax/syntax-tests.factor index f9fb9a218f..4b853770c2 100644 --- a/extra/alien/cxx/syntax/syntax-tests.factor +++ b/extra/alien/cxx/syntax/syntax-tests.factor @@ -15,10 +15,18 @@ C-TYPEDEF: std::string string C++-CLASS: std::string c++-root +C++-METHOD: std::string const-char* c_str ( ) + CM-FUNCTION: std::string* new_string ( const-char* s ) return new std::string(s); ; ;C-LIBRARY +ALIAS: new_string + +ALIAS: to-string c_str + { 1 1 } [ new_string ] must-infer-as +{ 1 1 } [ c_str ] must-infer-as +[ "abc" ] [ "abc" to-string ] unit-test diff --git a/extra/alien/cxx/syntax/syntax.factor b/extra/alien/cxx/syntax/syntax.factor index 741950f79b..59cf10e7de 100644 --- a/extra/alien/cxx/syntax/syntax.factor +++ b/extra/alien/cxx/syntax/syntax.factor @@ -3,4 +3,8 @@ USING: alien.cxx alien.cxx.parser ; IN: alien.cxx.syntax -SYNTAX: C++-CLASS: parse-c++-class-definition define-c++-class ; +SYNTAX: C++-CLASS: + parse-c++-class-definition define-c++-class ; + +SYNTAX: C++-METHOD: + parse-c++-method-definition define-c++-method ; From b869e1250c391a0713c542e19ecfaa857397cdc5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 00:52:25 -0500 Subject: [PATCH 06/52] compiler.cfg.stack-analysis: Out with the old, in with the new --- basis/compiler/cfg/optimizer/optimizer.factor | 16 +- basis/compiler/cfg/stack-analysis/authors.txt | 1 - .../stack-analysis/merge/merge-tests.factor | 104 --------- .../cfg/stack-analysis/merge/merge.factor | 117 ---------- .../stack-analysis-tests.factor | 204 ------------------ .../cfg/stack-analysis/stack-analysis.factor | 124 ----------- .../cfg/stack-analysis/state/state.factor | 53 ----- 7 files changed, 5 insertions(+), 614 deletions(-) delete mode 100644 basis/compiler/cfg/stack-analysis/authors.txt delete mode 100644 basis/compiler/cfg/stack-analysis/merge/merge-tests.factor delete mode 100644 basis/compiler/cfg/stack-analysis/merge/merge.factor delete mode 100644 basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor delete mode 100644 basis/compiler/cfg/stack-analysis/stack-analysis.factor delete mode 100644 basis/compiler/cfg/stack-analysis/state/state.factor diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index faaaccff61..ac6dcbc503 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -4,7 +4,6 @@ USING: kernel sequences accessors combinators namespaces compiler.cfg.tco compiler.cfg.predecessors compiler.cfg.useless-conditionals -compiler.cfg.stack-analysis compiler.cfg.dcn compiler.cfg.dominance compiler.cfg.ssa @@ -27,24 +26,19 @@ SYMBOL: check-optimizer? dup check-cfg ] when ; -SYMBOL: new-optimizer? - : optimize-cfg ( cfg -- cfg' ) ! Note that compute-predecessors has to be called several times. ! The passes that need this document it. [ optimize-tail-calls - new-optimizer? get [ delete-useless-conditionals ] unless + delete-useless-conditionals compute-predecessors - new-optimizer? get [ split-branches ] unless - new-optimizer? get [ - deconcatenatize - compute-dominance - construct-ssa - ] when + split-branches join-blocks compute-predecessors - new-optimizer? get [ stack-analysis ] unless + deconcatenatize + compute-dominance + construct-ssa compute-liveness alias-analysis value-numbering diff --git a/basis/compiler/cfg/stack-analysis/authors.txt b/basis/compiler/cfg/stack-analysis/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/compiler/cfg/stack-analysis/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor deleted file mode 100644 index 5883777861..0000000000 --- a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor +++ /dev/null @@ -1,104 +0,0 @@ -IN: compiler.cfg.stack-analysis.merge.tests -USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors - compiler.cfg.instructions compiler.cfg.stack-analysis.state -compiler.cfg.utilities compiler.cfg compiler.cfg.registers -compiler.cfg.debugger cpu.architecture make assocs namespaces -sequences kernel classes ; - -[ - { D 0 } - { V int-regs 0 V int-regs 1 } -] [ - - - V{ T{ ##branch } } >>instructions dup 1 set - V{ T{ ##branch } } >>instructions dup 2 set 2array - - H{ { D 0 V int-regs 0 } } >>locs>vregs - H{ { D 0 V int-regs 1 } } >>locs>vregs 2array - - H{ } clone added-instructions set - V{ } clone added-phis set - merge-locs locs>vregs>> keys added-phis get values first -] unit-test - -[ - { D 0 } - ##peek -] [ - - - V{ T{ ##branch } } >>instructions dup 1 set - V{ T{ ##branch } } >>instructions dup 2 set 2array - - - H{ { D 0 V int-regs 1 } } >>locs>vregs 2array - - H{ } clone added-instructions set - V{ } clone added-phis set - [ merge-locs locs>vregs>> keys ] { } make drop - 1 get added-instructions get at first class -] unit-test - -[ - 0 ##inc-d -] [ - - - V{ T{ ##branch } } >>instructions dup 1 set - V{ T{ ##branch } } >>instructions dup 2 set 2array - - H{ } clone added-instructions set - V{ } clone added-phis set - - -1 >>ds-height - 2array - - [ merge-ds-heights ds-height>> ] { } make drop - 1 get added-instructions get at first class -] unit-test - -[ - 0 - { D 0 } - { 1 1 } -] [ - - - V{ T{ ##branch } } >>instructions - V{ T{ ##branch } } >>instructions 2array - - H{ } clone added-instructions set - V{ } clone added-phis set - - [ - -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs - H{ { D 0 V int-regs 1 } } >>locs>vregs 2array - - [ merge-locs [ ds-height>> ] [ locs>vregs>> keys ] bi ] { } make drop - ] keep - [ instructions>> length ] map -] unit-test - -[ - -1 - { D -1 } - { 1 1 } -] [ - - - V{ T{ ##branch } } >>instructions - V{ T{ ##branch } } >>instructions 2array - - H{ } clone added-instructions set - V{ } clone added-phis set - - [ - -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs - -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array - - [ [ merge-ds-heights ] [ merge-locs ] 2bi ] { } make drop - [ ds-height>> ] [ locs>vregs>> keys ] bi - ] keep - [ instructions>> length ] map -] unit-test diff --git a/basis/compiler/cfg/stack-analysis/merge/merge.factor b/basis/compiler/cfg/stack-analysis/merge/merge.factor deleted file mode 100644 index a53fd7494e..0000000000 --- a/basis/compiler/cfg/stack-analysis/merge/merge.factor +++ /dev/null @@ -1,117 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel assocs sequences accessors fry combinators grouping sets -arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats -compiler.cfg.instructions compiler.cfg.stack-analysis.state -compiler.cfg.registers compiler.cfg.utilities cpu.architecture ; -IN: compiler.cfg.stack-analysis.merge - -: initial-state ( bb states -- state ) 2drop ; - -: single-predecessor ( bb states -- state ) nip first clone ; - -: save-ds-height ( n -- ) - dup 0 = [ drop ] [ ##inc-d ] if ; - -: merge-ds-heights ( state predecessors states -- state ) - [ ds-height>> ] map dup all-equal? - [ nip first >>ds-height ] - [ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ; - -: save-rs-height ( n -- ) - dup 0 = [ drop ] [ ##inc-r ] if ; - -: merge-rs-heights ( state predecessors states -- state ) - [ rs-height>> ] map dup all-equal? - [ nip first >>rs-height ] - [ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ; - -: assoc-map-keys ( assoc quot -- assoc' ) - '[ _ dip ] assoc-map ; inline - -: translate-locs ( assoc state -- assoc' ) - '[ _ translate-loc ] assoc-map-keys ; - -: untranslate-locs ( assoc state -- assoc' ) - '[ _ untranslate-loc ] assoc-map-keys ; - -: collect-locs ( loc-maps states -- assoc ) - ! assoc maps locs to sequences - [ untranslate-locs ] 2map - [ [ keys ] map concat prune ] keep - '[ dup _ [ at ] with map ] H{ } map>assoc ; - -: insert-peek ( predecessor loc state -- vreg ) - '[ _ _ translate-loc ^^peek ] add-instructions ; - -SYMBOL: added-phis - -: add-phi-later ( inputs -- vreg ) - [ int-regs next-vreg dup ] dip 2array added-phis get push ; - -: merge-loc ( predecessors vregs loc state -- vreg ) - ! Insert a ##phi in the current block where the input - ! is the vreg storing loc from each predecessor block - '[ [ ] [ _ _ insert-peek ] ?if ] 2map - dup all-equal? [ first ] [ add-phi-later ] if ; - -:: merge-locs ( state predecessors states -- state ) - states [ locs>vregs>> ] map states collect-locs - [| key value | - key - predecessors value key state merge-loc - ] assoc-map - state translate-locs - state (>>locs>vregs) - state ; - -: merge-actual-loc ( vregs -- vreg/f ) - dup all-equal? [ first ] [ drop f ] if ; - -:: merge-actual-locs ( state states -- state ) - states [ actual-locs>vregs>> ] map states collect-locs - [ merge-actual-loc ] assoc-map [ nip ] assoc-filter - state translate-locs - state (>>actual-locs>vregs) - state ; - -: merge-changed-locs ( state states -- state ) - [ [ changed-locs>> ] keep untranslate-locs ] map assoc-combine - over translate-locs - >>changed-locs ; - -:: insert-phis ( bb -- ) - bb predecessors>> :> predecessors - [ - added-phis get [| dst inputs | - dst predecessors inputs zip ##phi - ] assoc-each - ] V{ } make bb instructions>> over push-all - bb (>>instructions) ; - -:: multiple-predecessors ( bb states -- state ) - states [ not ] any? [ - - bb add-to-work-list - ] [ - [ - H{ } clone added-instructions set - V{ } clone added-phis set - bb predecessors>> :> predecessors - state new - predecessors states merge-ds-heights - predecessors states merge-rs-heights - predecessors states merge-locs - states merge-actual-locs - states merge-changed-locs - bb insert-basic-blocks - bb insert-phis - ] with-scope - ] if ; - -: merge-states ( bb states -- state ) - dup length { - { 0 [ initial-state ] } - { 1 [ single-predecessor ] } - [ drop multiple-predecessors ] - } case ; diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor deleted file mode 100644 index 9fbf7acf78..0000000000 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ /dev/null @@ -1,204 +0,0 @@ -USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization -compiler.cfg.predecessors compiler.cfg.stack-analysis -compiler.cfg.instructions sequences kernel tools.test accessors -sequences.private alien math combinators.private compiler.cfg -compiler.cfg.checker compiler.cfg.rpo -compiler.cfg.dce compiler.cfg.registers -sets namespaces arrays cpu.architecture ; -IN: compiler.cfg.stack-analysis.tests - -! Fundamental invariant: a basic block should not load or store a value more than once -: test-stack-analysis ( quot -- cfg ) - dup cfg? [ test-cfg first ] unless - compute-predecessors - stack-analysis - dup check-cfg ; - -: linearize ( cfg -- mr ) - flatten-cfg instructions>> ; - -[ ] [ [ ] test-stack-analysis drop ] unit-test - -! Only peek once -[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test - -! Redundant replace is redundant -[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test -[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test - -! Replace required here -[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test -[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test - -! Only one replace, at the end -[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test - -! Do we support the full language? -[ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test -[ ] [ [ { [ ] [ ] } dispatch dup ] test-stack-analysis drop ] unit-test -[ ] [ - [ "int" { "int" "int" } "cdecl" [ + ] alien-callback ] - test-cfg second test-stack-analysis drop -] unit-test - -! Test loops -[ ] [ [ [ t ] loop ] test-stack-analysis drop ] unit-test -[ ] [ [ [ dup ] loop ] test-stack-analysis drop ] unit-test - -! Make sure that peeks are inserted in the right place -[ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test - -! This should be a total no-op -[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test - -! Don't insert inc-d/inc-r; that's wrong! -[ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test - -! Bug in height tracking -[ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test -[ ] [ [ dup [ ] [ dup reverse drop ] if ] test-stack-analysis drop ] unit-test -[ ] [ [ [ drop dup 4.0 > ] find-last-integer ] test-stack-analysis drop ] unit-test - -! Bugs with code that throws -[ ] [ [ [ "Oops" throw ] unless ] test-stack-analysis drop ] unit-test -[ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test -[ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test -[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test - -! Make sure the replace stores a value with the right height -[ ] [ - [ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize - [ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi -] unit-test - -! translate-loc was the wrong way round -[ ] [ - [ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize - [ [ ##load-immediate? ] count 2 assert= ] - [ [ ##peek? ] count 1 assert= ] - [ [ ##replace? ] count 3 assert= ] - tri -] unit-test - -[ ] [ - [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize - [ [ ##load-immediate? ] count 2 assert= ] - [ [ ##peek? ] count 1 assert= ] - [ [ ##replace? ] count 1 assert= ] - tri -] unit-test - -! Sync before a back-edge, not after -! ##peeks should be inserted before a ##loop-entry -! Don't optimize out the constants -[ t ] [ - [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize - [ ##load-immediate? ] any? -] unit-test - -! Correct height tracking -[ t ] [ - [ pick [ ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code - reverse-post-order 4 swap nth - instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi* - 2array { D 1 D 0 } set= -] unit-test - -[ D 1 ] [ - V{ T{ ##branch } } 0 test-bb - - V{ T{ ##peek f V int-regs 0 D 2 } T{ ##branch } } 1 test-bb - - V{ - T{ ##peek f V int-regs 1 D 2 } - T{ ##inc-d f -1 } - T{ ##branch } - } 2 test-bb - - V{ T{ ##call f \ + -1 } T{ ##branch } } 3 test-bb - - V{ T{ ##return } } 4 test-bb - - test-diamond - - cfg new 0 get >>entry - compute-predecessors - stack-analysis - drop - - 3 get successors>> first instructions>> first loc>> -] unit-test - -! Do inserted ##peeks reference the correct stack location if -! an ##inc-d/r was also inserted? -[ D 0 ] [ - V{ T{ ##branch } } 0 test-bb - - V{ T{ ##branch } } 1 test-bb - - V{ - T{ ##peek f V int-regs 1 D 0 } - T{ ##branch } - } 2 test-bb - - V{ - T{ ##call f \ + -1 } - T{ ##inc-d f 1 } - T{ ##branch } - } 3 test-bb - - V{ T{ ##return } } 4 test-bb - - test-diamond - - cfg new 0 get >>entry - compute-predecessors - stack-analysis - drop - - 3 get successors>> first instructions>> [ ##peek? ] find nip loc>> -] unit-test - -! Missing ##replace -[ t ] [ - [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis - reverse-post-order last - instructions>> [ ##replace? ] filter [ loc>> ] map - { D 0 D 1 D 2 } set= -] unit-test - -! Inserted ##peeks reference the wrong stack location -[ t ] [ - [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis - eliminate-dead-code reverse-post-order 4 swap nth - instructions>> [ ##peek? ] filter [ loc>> ] map - { D 0 D 1 } set= -] unit-test - -[ D 0 ] [ - V{ T{ ##branch } } 0 test-bb - - V{ T{ ##branch } } 1 test-bb - - V{ - T{ ##peek f V int-regs 1 D 0 } - T{ ##inc-d f 1 } - T{ ##branch } - } 2 test-bb - - V{ - T{ ##inc-d f 1 } - T{ ##branch } - } 3 test-bb - - V{ T{ ##return } } 4 test-bb - - test-diamond - - cfg new 0 get >>entry - compute-predecessors - stack-analysis - drop - - 3 get successors>> first instructions>> [ ##peek? ] find nip loc>> -] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor deleted file mode 100644 index ec34c96a24..0000000000 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ /dev/null @@ -1,124 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel namespaces math sequences fry grouping -sets make combinators dlists deques -compiler.cfg -compiler.cfg.copy-prop -compiler.cfg.def-use -compiler.cfg.instructions -compiler.cfg.registers -compiler.cfg.rpo -compiler.cfg.hats -compiler.cfg.stack-analysis.state -compiler.cfg.stack-analysis.merge -compiler.cfg.utilities ; -IN: compiler.cfg.stack-analysis - -SYMBOL: global-optimization? - -: redundant-replace? ( vreg loc -- ? ) - dup state get untranslate-loc n>> 0 < - [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ; - -: save-changed-locs ( state -- ) - [ changed-locs>> keys ] [ locs>vregs>> ] bi '[ - dup _ at swap 2dup redundant-replace? - [ 2drop ] [ state get untranslate-loc ##replace ] if - ] each ; - -: sync-state ( -- ) - state get { - [ ds-height>> save-ds-height ] - [ rs-height>> save-rs-height ] - [ save-changed-locs ] - [ clear-state ] - } cleave ; - -! Abstract interpretation -GENERIC: visit ( insn -- ) - -M: ##inc-d visit - n>> state get [ + ] change-ds-height drop ; - -M: ##inc-r visit - n>> state get [ + ] change-rs-height drop ; - -! Instructions which don't have any effect on the stack -UNION: neutral-insn - ##effect - ##flushable - ##no-tco ; - -M: neutral-insn visit , ; - -UNION: sync-if-back-edge - ##branch - ##conditional-branch - ##compare-imm-branch - ##dispatch - ##loop-entry - ##fixnum-overflow ; - -: sync-state? ( -- ? ) - basic-block get successors>> - [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ; - -M: sync-if-back-edge visit - global-optimization? get [ sync-state? [ sync-state ] when ] unless - , ; - -: eliminate-peek ( dst src -- ) - ! the requested stack location is already in 'src' - [ ##copy ] [ swap copies get set-at ] 2bi ; - -M: ##peek visit - [ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg - [ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ; - -M: ##replace visit - [ src>> resolve ] [ loc>> state get translate-loc ] bi - record-replace ; - -M: ##copy visit - [ call-next-method ] [ record-copy ] bi ; - -M: ##jump visit sync-state , ; - -M: ##return visit sync-state , ; - -M: ##callback-return visit sync-state , ; - -M: kill-vreg-insn visit sync-state , ; - -! Maps basic-blocks to states -SYMBOL: state-out - -: block-in-state ( bb -- states ) - dup predecessors>> state-out get '[ _ at ] map merge-states ; - -: set-block-out-state ( state bb -- ) - [ clone ] dip state-out get set-at ; - -: visit-block ( bb -- ) - ! block-in-state may add phi nodes at the start of the basic block - ! so we wrap the whole thing with a 'make' - [ - dup basic-block set - dup block-in-state - state [ - [ instructions>> [ visit ] each ] - [ [ state get ] dip set-block-out-state ] - [ ] - tri - ] with-variable - ] V{ } make >>instructions drop ; - -: stack-analysis ( cfg -- cfg' ) - [ - work-list set - H{ } clone copies set - H{ } clone state-out set - dup [ visit-block ] each-basic-block - global-optimization? get [ work-list get [ visit-block ] slurp-deque ] when - cfg-changed - ] with-scope ; diff --git a/basis/compiler/cfg/stack-analysis/state/state.factor b/basis/compiler/cfg/stack-analysis/state/state.factor deleted file mode 100644 index 25fa249853..0000000000 --- a/basis/compiler/cfg/stack-analysis/state/state.factor +++ /dev/null @@ -1,53 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors namespaces assocs sets math deques -compiler.cfg.registers ; -IN: compiler.cfg.stack-analysis.state - -TUPLE: state -locs>vregs actual-locs>vregs changed-locs -{ ds-height integer } -{ rs-height integer } -poisoned? ; - -: ( -- state ) - state new - H{ } clone >>locs>vregs - H{ } clone >>actual-locs>vregs - H{ } clone >>changed-locs - 0 >>ds-height - 0 >>rs-height ; - -M: state clone - call-next-method - [ clone ] change-locs>vregs - [ clone ] change-actual-locs>vregs - [ clone ] change-changed-locs ; - -: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ; - -: record-peek ( dst loc -- ) - state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ; - -: changed-loc ( loc -- ) - state get changed-locs>> conjoin ; - -: record-replace ( src loc -- ) - dup changed-loc state get locs>vregs>> set-at ; - -: clear-state ( state -- ) - 0 >>ds-height 0 >>rs-height - [ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri - [ clear-assoc ] tri@ ; - -GENERIC# translate-loc 1 ( loc state -- loc' ) -M: ds-loc translate-loc [ n>> ] [ ds-height>> ] bi* - ; -M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - ; - -GENERIC# untranslate-loc 1 ( loc state -- loc' ) -M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + ; -M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + ; - -SYMBOL: work-list - -: add-to-work-list ( bb -- ) work-list get push-front ; From b39b0dd393b437f3f7e9ac541d900770143552bc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 02:05:40 -0500 Subject: [PATCH 07/52] compiler.cfg.dcn.global: redo using compiler.cfg.dataflow-analysis --- basis/compiler/cfg/dcn/global/global.factor | 175 ++------------------ 1 file changed, 10 insertions(+), 165 deletions(-) diff --git a/basis/compiler/cfg/dcn/global/global.factor b/basis/compiler/cfg/dcn/global/global.factor index d644ed8703..44f8af24cc 100644 --- a/basis/compiler/cfg/dcn/global/global.factor +++ b/basis/compiler/cfg/dcn/global/global.factor @@ -1,194 +1,39 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs deques dlists fry kernel namespaces sequences -combinators combinators.short-circuit compiler.cfg.instructions -compiler.cfg.dcn.local compiler.cfg.rpo compiler.cfg.utilities -compiler.cfg ; +USING: assocs kernel combinators compiler.cfg.dataflow-analysis +compiler.cfg.dcn.local ; IN: compiler.cfg.dcn.global - -: peek-in ( bb -- assoc ) peek-ins get at ; -: peek-out ( bb -- assoc ) peek-outs get at ; - -> peek-ins get '[ _ at ] map assoc-refine ; - -M: kill-block compute-peek-out drop f ; - -: update-peek-out ( bb -- ? ) - [ compute-peek-out ] keep peek-outs get maybe-set-at ; - -: peek-step ( bb -- ) - dup update-peek-out [ - dup update-peek-in - [ predecessors>> add-to-work-list ] [ drop ] if - ] [ drop ] if ; - -: compute-peek-sets ( cfg -- ) - H{ } clone peek-ins set - H{ } clone peek-outs set - post-order add-to-work-list work-list get [ peek-step ] slurp-deque ; +M: peek-analysis transfer-set drop [ replace assoc-diff ] keep peek assoc-union ; ! Replace analysis. Replace-in is the set of all locations which ! will be overwritten at some point after the start of a basic block. -SYMBOLS: replace-ins replace-outs ; +FORWARD-ANALYSIS: replace -PRIVATE> - -: replace-in ( bb -- assoc ) replace-ins get at ; -: replace-out ( bb -- assoc ) replace-outs get at ; - -> replace-outs get '[ _ at ] map assoc-refine ; - -M: kill-block compute-replace-in drop f ; - -: update-replace-in ( bb -- ? ) - [ compute-replace-in ] keep replace-ins get maybe-set-at ; - -GENERIC: compute-replace-out ( bb -- assoc ) - -M: basic-block compute-replace-out - [ replace-in ] [ replace ] bi assoc-union ; - -M: kill-block compute-replace-out drop f ; - -: update-replace-out ( bb -- ? ) - [ compute-replace-out ] keep replace-outs get maybe-set-at ; - -: replace-step ( bb -- ) - dup update-replace-in [ - dup update-replace-out - [ successors>> add-to-work-list ] [ drop ] if - ] [ drop ] if ; - -: compute-replace-sets ( cfg -- ) - H{ } clone replace-ins set - H{ } clone replace-outs set - reverse-post-order add-to-work-list work-list get [ replace-step ] slurp-deque ; +M: replace-analysis transfer-set drop replace assoc-union ; ! Availability analysis. Avail-out is the set of all locations ! in registers at the end of a basic block. -SYMBOLS: avail-ins avail-outs ; +FORWARD-ANALYSIS: avail -PRIVATE> - -: avail-in ( bb -- assoc ) avail-ins get at ; -: avail-out ( bb -- assoc ) avail-outs get at ; - -> avail-outs get '[ _ at ] map assoc-refine ; - -M: kill-block compute-avail-in drop f ; - -: update-avail-in ( bb -- ? ) - [ compute-avail-in ] keep avail-ins get maybe-set-at ; - -GENERIC: compute-avail-out ( bb -- assoc ) - -M: basic-block compute-avail-out - [ avail-in ] [ peek ] [ replace ] tri assoc-union assoc-union ; - -M: kill-block compute-avail-out drop f ; - -: update-avail-out ( bb -- ? ) - [ compute-avail-out ] keep avail-outs get maybe-set-at ; - -: avail-step ( bb -- ) - dup update-avail-in [ - dup update-avail-out - [ successors>> add-to-work-list ] [ drop ] if - ] [ drop ] if ; - -: compute-avail-sets ( cfg -- ) - H{ } clone avail-ins set - H{ } clone avail-outs set - reverse-post-order add-to-work-list work-list get [ avail-step ] slurp-deque ; +M: avail-analysis transfer-set drop [ peek ] [ replace ] bi assoc-union assoc-union ; ! Kill analysis. Kill-in is the set of all locations ! which are going to be overwritten. -SYMBOLS: kill-ins kill-outs ; +BACKWARD-ANALYSIS: kill -PRIVATE> - -: kill-in ( bb -- assoc ) kill-ins get at ; -: kill-out ( bb -- assoc ) kill-outs get at ; - -> kill-ins get '[ _ at ] map assoc-refine ; - -M: kill-block compute-kill-out drop f ; - -: update-kill-out ( bb -- ? ) - [ compute-kill-out ] keep kill-outs get maybe-set-at ; - -: kill-step ( bb -- ) - dup update-kill-out [ - dup update-kill-in - [ predecessors>> add-to-work-list ] [ drop ] if - ] [ drop ] if ; - -: compute-kill-sets ( cfg -- ) - H{ } clone kill-ins set - H{ } clone kill-outs set - post-order add-to-work-list work-list get [ kill-step ] slurp-deque ; +M: kill-analysis transfer-set drop replace assoc-union ; PRIVATE> ! Main word : compute-global-sets ( cfg -- ) - work-list set { [ compute-peek-sets ] [ compute-replace-sets ] From 42230b21a3b76fae48f6fdc0dda61d6f9fd661ec Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 02:06:14 -0500 Subject: [PATCH 08/52] Add assoc-refine, which takes the intersection of a sequence of assocs --- core/assocs/assocs-tests.factor | 16 ++++++++++++++++ core/assocs/assocs.factor | 3 +++ 2 files changed, 19 insertions(+) diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 75607b0258..3c5ac31d23 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -134,3 +134,19 @@ unit-test [ f ] [ 1 2 H{ { 2 1 } } maybe-set-at ] unit-test [ t ] [ 1 3 H{ { 2 1 } } clone maybe-set-at ] unit-test [ t ] [ 3 2 H{ { 2 1 } } clone maybe-set-at ] unit-test + +[ H{ { 1 2 } { 2 3 } } ] [ + { + H{ { 1 3 } } + H{ { 2 3 } } + H{ { 1 2 } } + } assoc-combine +] unit-test + +[ H{ { 1 7 } } ] [ + { + H{ { 1 2 } { 2 4 } { 5 6 } } + H{ { 1 3 } { 2 5 } } + H{ { 1 7 } { 5 6 } } + } assoc-refine +] unit-test \ No newline at end of file diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 62ab9f86ae..8b6809236c 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -129,6 +129,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : assoc-combine ( seq -- union ) H{ } clone [ dupd update ] reduce ; +: assoc-refine ( seq -- assoc ) + [ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ; + : assoc-diff ( assoc1 assoc2 -- diff ) [ nip key? not ] curry assoc-filter ; From dce020ca711d5157910c61214042cba41d5682b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 02:06:24 -0500 Subject: [PATCH 09/52] functors: add MIXIN:, SINGLETON: --- basis/functors/functors.factor | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 6ffc4d8112..5129515980 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays classes.mixin classes.parser -classes.tuple classes.tuple.parser combinators effects -effects.parser fry generic generic.parser generic.standard -interpolate io.streams.string kernel lexer locals.parser -locals.rewrite.closures locals.types make namespaces parser -quotations sequences vocabs.parser words words.symbol ; +USING: accessors arrays classes.mixin classes.parser classes.singleton +classes.tuple classes.tuple.parser combinators effects effects.parser +fry generic generic.parser generic.standard interpolate +io.streams.string kernel lexer locals.parser locals.rewrite.closures +locals.types make namespaces parser quotations sequences vocabs.parser +words words.symbol ; IN: functors ! This is a hack @@ -71,6 +71,14 @@ SYNTAX: `TUPLE: } case \ define-tuple-class parsed ; +SYNTAX: `SINGLETON: + scan-param parsed + \ define-singleton-class parsed ; + +SYNTAX: `MIXIN: + scan-param parsed + \ define-mixin-class parsed ; + SYNTAX: `M: scan-param parsed scan-param parsed @@ -134,6 +142,8 @@ DEFER: ;FUNCTOR delimiter : functor-words ( -- assoc ) H{ { "TUPLE:" POSTPONE: `TUPLE: } + { "SINGLETON:" POSTPONE: `SINGLETON: } + { "MIXIN:" POSTPONE: `MIXIN: } { "M:" POSTPONE: `M: } { "C:" POSTPONE: `C: } { ":" POSTPONE: `: } From e6a323dfaae4b956b06d0afad1e5f9a84c33b3b9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 02:06:35 -0500 Subject: [PATCH 10/52] compiler.cfg.dataflow-analysis: iterative dataflow analysis framework --- .../dataflow-analysis.factor | 140 ++++++++++++++++++ 1 file changed, 140 insertions(+) create mode 100644 basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor new file mode 100644 index 0000000000..975adfa6cb --- /dev/null +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -0,0 +1,140 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs deques dlists kernel locals sequences lexer +namespaces functors compiler.cfg.rpo compiler.cfg.utilities +compiler.cfg ; +IN: compiler.cfg.dataflow-analysis + +GENERIC: join-sets ( sets dfa -- set ) +GENERIC: transfer-set ( in-set bb dfa -- out-set ) +GENERIC: block-order ( cfg dfa -- bbs ) +GENERIC: successors ( bb dfa -- seq ) +GENERIC: predecessors ( bb dfa -- seq ) + + ( cfg dfa -- queue ) + block-order [ push-all-front ] keep ; + +GENERIC# compute-in-set 2 ( bb out-sets dfa -- set ) + +M: kill-block compute-in-set 3drop f ; + +M:: basic-block compute-in-set ( bb out-sets dfa -- set ) + bb dfa predecessors [ out-sets at ] map dfa join-sets ; + +:: update-in-set ( bb in-sets out-sets dfa -- ? ) + bb out-sets dfa compute-in-set + bb in-sets maybe-set-at ; inline + +GENERIC# compute-out-set 2 ( bb out-sets dfa -- set ) + +M: kill-block compute-out-set 3drop f ; + +M:: basic-block compute-out-set ( bb in-sets dfa -- set ) + bb in-sets at bb dfa transfer-set ; + +:: update-out-set ( bb in-sets out-sets dfa -- ? ) + bb in-sets dfa compute-out-set + bb out-sets maybe-set-at ; inline + +:: dfa-step ( bb in-sets out-sets dfa work-list -- ) + bb in-sets out-sets dfa update-in-set [ + bb in-sets out-sets dfa update-out-set [ + bb dfa successors work-list push-all-front + ] when + ] when ; inline + +:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets ) + H{ } clone :> in-sets + H{ } clone :> out-sets + cfg dfa :> work-list + work-list [ in-sets out-sets dfa work-list dfa-step ] slurp-deque + in-sets + out-sets ; inline + +M: dataflow-analysis join-sets drop assoc-refine ; + +FUNCTOR: define-analysis ( name -- ) + +name-analysis DEFINES-CLASS ${name}-analysis +name-ins DEFINES ${name}-ins +name-outs DEFINES ${name}-outs +name-in DEFINES ${name}-in +name-out DEFINES ${name}-out + +WHERE + +SINGLETON: name-analysis + +SYMBOL: name-ins + +: name-in ( bb -- set ) name-ins get at ; + +SYMBOL: name-outs + +: name-out ( bb -- set ) name-outs get at ; + +;FUNCTOR + +! ! ! Forward dataflow analysis + +MIXIN: forward-analysis +INSTANCE: forward-analysis dataflow-analysis + +M: forward-analysis block-order drop reverse-post-order ; +M: forward-analysis successors drop successors>> ; +M: forward-analysis predecessors drop predecessors>> ; + +FUNCTOR: define-forward-analysis ( name -- ) + +name-analysis IS ${name}-analysis +name-ins IS ${name}-ins +name-outs IS ${name}-outs +compute-name-sets DEFINES compute-${name}-sets + +WHERE + +INSTANCE: name-analysis forward-analysis + +: compute-name-sets ( cfg -- ) + name-analysis run-dataflow-analysis + [ name-ins set ] [ name-outs set ] bi* ; + +;FUNCTOR + +! ! ! Backward dataflow analysis + +MIXIN: backward-analysis +INSTANCE: backward-analysis dataflow-analysis + +M: backward-analysis block-order drop post-order ; +M: backward-analysis successors drop predecessors>> ; +M: backward-analysis predecessors drop successors>> ; + +FUNCTOR: define-backward-analysis ( name -- ) + +name-analysis IS ${name}-analysis +name-ins IS ${name}-ins +name-outs IS ${name}-outs +compute-name-sets DEFINES compute-${name}-sets + +WHERE + +INSTANCE: name-analysis backward-analysis + +: compute-name-sets ( cfg -- ) + \ name-analysis run-dataflow-analysis + [ name-outs set ] [ name-ins set ] bi* ; + +;FUNCTOR + +PRIVATE> + +SYNTAX: FORWARD-ANALYSIS: + scan [ define-analysis ] [ define-forward-analysis ] bi ; + +SYNTAX: BACKWARD-ANALYSIS: + scan [ define-analysis ] [ define-backward-analysis ] bi ; From 8d4585edefb2b6a32273af62f8bff9de1dd984ca Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 22 Jul 2009 19:20:01 +1200 Subject: [PATCH 11/52] alien.marshall: tidy unmarshallers --- extra/alien/marshall/marshall.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor index eec0cadcbb..547e37f78a 100644 --- a/extra/alien/marshall/marshall.factor +++ b/extra/alien/marshall/marshall.factor @@ -275,21 +275,21 @@ ALIAS: marshall-void* marshall-pointer : ?malloc-byte-array ( c-type -- alien ) dup alien? [ malloc-byte-array ] unless ; -:: x-unmarshaller ( type type-quot wrapper-test def clean -- quot/f ) +:: x-unmarshaller ( type type-quot superclass def clean -- quot/f ) type type-quot call current-vocab lookup [ - dup superclasses wrapper-test any? + dup superclasses superclass swap member? [ def call ] [ drop clean call f ] if ] [ clean call f ] if* ; inline : struct-unmarshaller ( type -- quot/f ) - [ ] [ \ struct-wrapper = ] + [ ] \ struct-wrapper [ '[ ?malloc-byte-array _ new swap >>underlying ] ] [ ] x-unmarshaller ; : class-unmarshaller ( type -- quot/f ) - [ type-sans-pointer ] [ \ alien-wrapper = ] - [ '[ ?malloc-byte-array _ new swap >>underlying ] ] + [ type-sans-pointer "#" append ] \ class-wrapper + [ '[ _ new swap >>underlying ] ] [ ] x-unmarshaller ; From 7ad0924df27d47fdf87f18e72e809e1f482d944b Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 22 Jul 2009 19:20:26 +1200 Subject: [PATCH 12/52] alien.cxx: methods and virtual methods --- extra/alien/cxx/cxx.factor | 16 ++-- extra/alien/cxx/parser/parser.factor | 4 +- extra/alien/cxx/syntax/syntax-tests.factor | 91 ++++++++++++++++++++-- extra/alien/cxx/syntax/syntax.factor | 5 +- 4 files changed, 102 insertions(+), 14 deletions(-) diff --git a/extra/alien/cxx/cxx.factor b/extra/alien/cxx/cxx.factor index ab7ff416fa..9d0ee24f50 100644 --- a/extra/alien/cxx/cxx.factor +++ b/extra/alien/cxx/cxx.factor @@ -3,7 +3,8 @@ USING: accessors alien.c-types alien.cxx.parser alien.marshall alien.inline.types classes.mixin classes.tuple kernel namespaces assocs sequences parser classes.parser alien.marshall.syntax -interpolate locals effects io strings ; +interpolate locals effects io strings make vocabs.parser words +generic fry quotations ; IN: alien.cxx [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip add-mixin-instance define-class-tuple ; -:: define-c++-method ( class-name name types effect -- ) +:: define-c++-method ( class-name generic name types effect virtual -- ) + [ name % "_" % class-name { { CHAR: : CHAR: _ } } substitute % ] "" make :> name' effect [ in>> "self" suffix ] [ out>> ] bi :> effect' - types class-name "*" append suffix :> types' - effect in>> "," join :> args - SBUF" " dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body - name types' effect' body define-c-marshalled ; + types class-name "*" append suffix :> types' + effect in>> "," join :> args + class-name virtual [ "#" append ] unless current-vocab lookup :> class + SBUF" " clone dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body + name' types' effect' body define-c-marshalled + class generic create-method name' current-vocab lookup 1quotation define ; diff --git a/extra/alien/cxx/parser/parser.factor b/extra/alien/cxx/parser/parser.factor index 84425649da..5afaab29e0 100644 --- a/extra/alien/cxx/parser/parser.factor +++ b/extra/alien/cxx/parser/parser.factor @@ -6,5 +6,5 @@ IN: alien.cxx.parser : parse-c++-class-definition ( -- class superclass-mixin ) scan scan-word ; -: parse-c++-method-definition ( -- class-name name types effect ) - scan function-types-effect ; +: parse-c++-method-definition ( -- class-name generic name types effect ) + scan scan-word function-types-effect ; diff --git a/extra/alien/cxx/syntax/syntax-tests.factor b/extra/alien/cxx/syntax/syntax-tests.factor index 4b853770c2..24f685a197 100644 --- a/extra/alien/cxx/syntax/syntax-tests.factor +++ b/extra/alien/cxx/syntax/syntax-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test alien.cxx.syntax alien.inline.syntax -alien.marshall.syntax alien.marshall ; +alien.marshall.syntax alien.marshall accessors kernel ; IN: alien.cxx.syntax.tests DELETE-C-LIBRARY: test @@ -15,7 +15,9 @@ C-TYPEDEF: std::string string C++-CLASS: std::string c++-root -C++-METHOD: std::string const-char* c_str ( ) +GENERIC: to-string ( obj -- str ) + +C++-METHOD: std::string to-string const-char* c_str ( ) CM-FUNCTION: std::string* new_string ( const-char* s ) return new std::string(s); @@ -25,8 +27,87 @@ CM-FUNCTION: std::string* new_string ( const-char* s ) ALIAS: new_string -ALIAS: to-string c_str - { 1 1 } [ new_string ] must-infer-as -{ 1 1 } [ c_str ] must-infer-as +{ 1 1 } [ c_str_std__string ] must-infer-as +[ t ] [ "abc" std::string? ] unit-test [ "abc" ] [ "abc" to-string ] unit-test + + +DELETE-C-LIBRARY: inheritance +C-LIBRARY: inheritance + +COMPILE-AS-C++ + +C-INCLUDE: + +RAW-C: +class alpha { + public: + alpha(const char* s) { + str = s; + }; + const char* render() { + return str; + }; + virtual const char* chop() { + return str; + }; + virtual int length() { + return strlen(str); + }; + const char* str; +}; + +class beta : alpha { + public: + beta(const char* s) : alpha(s + 1) { }; + const char* render() { + return str + 1; + }; + virtual const char* chop() { + return str + 2; + }; +}; +; + +C++-CLASS: alpha c++-root +C++-CLASS: beta alpha + +CM-FUNCTION: alpha* new_alpha ( const-char* s ) + return new alpha(s); +; + +CM-FUNCTION: beta* new_beta ( const-char* s ) + return new beta(s); +; + +ALIAS: new_alpha +ALIAS: new_beta + +GENERIC: render ( obj -- obj ) +GENERIC: chop ( obj -- obj ) +GENERIC: length ( obj -- n ) + +C++-METHOD: alpha render const-char* render ( ) +C++-METHOD: beta render const-char* render ( ) +C++-VIRTUAL: alpha chop const-char* chop ( ) +C++-VIRTUAL: beta chop const-char* chop ( ) +C++-VIRTUAL: alpha length int length ( ) + +;C-LIBRARY + +{ 1 1 } [ render_alpha ] must-infer-as +{ 1 1 } [ chop_beta ] must-infer-as +{ 1 1 } [ length_alpha ] must-infer-as +[ t ] [ "x" alpha#? ] unit-test +[ t ] [ "x" alpha? ] unit-test +[ t ] [ "x" alpha? ] unit-test +[ f ] [ "x" alpha#? ] unit-test +[ 5 ] [ "hello" length ] unit-test +[ 4 ] [ "hello" length ] unit-test +[ "hello" ] [ "hello" render ] unit-test +[ "llo" ] [ "hello" render ] unit-test +[ "ello" ] [ "hello" underlying>> \ alpha# new swap >>underlying render ] unit-test +[ "hello" ] [ "hello" chop ] unit-test +[ "lo" ] [ "hello" chop ] unit-test +[ "lo" ] [ "hello" underlying>> \ alpha# new swap >>underlying chop ] unit-test diff --git a/extra/alien/cxx/syntax/syntax.factor b/extra/alien/cxx/syntax/syntax.factor index 59cf10e7de..66c72c1c2b 100644 --- a/extra/alien/cxx/syntax/syntax.factor +++ b/extra/alien/cxx/syntax/syntax.factor @@ -7,4 +7,7 @@ SYNTAX: C++-CLASS: parse-c++-class-definition define-c++-class ; SYNTAX: C++-METHOD: - parse-c++-method-definition define-c++-method ; + parse-c++-method-definition f define-c++-method ; + +SYNTAX: C++-VIRTUAL: + parse-c++-method-definition t define-c++-method ; From f261752dd1059ed115c9cfe2f12f16348285036a Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 22 Jul 2009 19:30:55 +1200 Subject: [PATCH 13/52] alien.inline.types: a trifling matter --- extra/alien/inline/types/types.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/alien/inline/types/types.factor b/extra/alien/inline/types/types.factor index 34162f422e..070febc324 100644 --- a/extra/alien/inline/types/types.factor +++ b/extra/alien/inline/types/types.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types assocs combinators.short-circuit continuations effects fry kernel math memoize sequences -splitting strings peg.ebnf make alien.c-types ; +splitting strings peg.ebnf make ; IN: alien.inline.types : cify-type ( str -- str' ) From 21a012e3d765730dacf1ccff8796a0d9153e487f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 03:08:28 -0500 Subject: [PATCH 14/52] compiler.cfg: Major restructuring -- do not compute liveness before local optimization, and instead change local optimizations to be more permissive of undefined values. Now, liveness is only computed once, after phi elimination and before register allocation. This means liveness analysis does not need to take phi nodes into account and can now use the new compiler.cfg.dataflow-analysis framework --- .../cfg/alias-analysis/alias-analysis.factor | 13 +- basis/compiler/cfg/checker/checker.factor | 6 +- .../dataflow-analysis.factor | 4 +- basis/compiler/cfg/debugger/debugger.factor | 2 +- basis/compiler/cfg/def-use/def-use.factor | 12 +- .../linear-scan/assignment/assignment.factor | 9 +- .../cfg/linear-scan/linear-scan-tests.factor | 11 +- .../cfg/linear-scan/linear-scan.factor | 16 +- .../live-intervals/live-intervals.factor | 7 +- .../cfg/linear-scan/liveness/liveness.factor | 17 +++ .../linear-scan/numbering/numbering.factor | 9 +- .../cfg/linear-scan/resolve/resolve.factor | 8 +- .../cfg/linearization/linearization.factor | 1 - basis/compiler/cfg/liveness/authors.txt | 1 - .../cfg/liveness/liveness-tests.factor | 15 -- basis/compiler/cfg/liveness/liveness.factor | 79 ---------- basis/compiler/cfg/local/authors.txt | 1 - basis/compiler/cfg/local/local.factor | 14 -- basis/compiler/cfg/mr/mr.factor | 3 +- basis/compiler/cfg/optimizer/optimizer.factor | 2 - basis/compiler/cfg/renaming/renaming.factor | 2 +- basis/compiler/cfg/rpo/rpo.factor | 7 + .../cfg/two-operand/two-operand.factor | 3 +- .../expressions/expressions.factor | 14 +- .../cfg/value-numbering/graph/graph.factor | 13 +- .../value-numbering-tests.factor | 140 +++++++++--------- .../value-numbering/value-numbering.factor | 20 +-- .../cfg/write-barrier/write-barrier.factor | 4 +- 28 files changed, 170 insertions(+), 263 deletions(-) create mode 100644 basis/compiler/cfg/linear-scan/liveness/liveness.factor delete mode 100644 basis/compiler/cfg/liveness/authors.txt delete mode 100644 basis/compiler/cfg/liveness/liveness-tests.factor delete mode 100644 basis/compiler/cfg/liveness/liveness.factor delete mode 100644 basis/compiler/cfg/local/authors.txt delete mode 100644 basis/compiler/cfg/local/local.factor diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index d0bb792f72..78e271c1f6 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -3,8 +3,7 @@ USING: kernel math namespaces assocs hashtables sequences arrays accessors vectors combinators sets classes compiler.cfg compiler.cfg.registers compiler.cfg.instructions -compiler.cfg.copy-prop compiler.cfg.rpo -compiler.cfg.liveness compiler.cfg.local ; +compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.def-use ; IN: compiler.cfg.alias-analysis ! We try to eliminate redundant slot operations using some simple heuristics. @@ -197,7 +196,10 @@ M: ##set-slot insn-object obj>> resolve ; M: ##set-slot-imm insn-object obj>> resolve ; M: ##alien-global insn-object drop \ ##alien-global ; -: init-alias-analysis ( live-in -- ) +: inputs ( insns -- seq ) + [ [ ##phi? not ] filter gen-set ] [ kill-set ] bi assoc-diff keys ; + +: init-alias-analysis ( insns -- insns' ) H{ } clone histories set H{ } clone vregs>acs set H{ } clone acs>vregs set @@ -208,7 +210,7 @@ M: ##alien-global insn-object drop \ ##alien-global ; 0 ac-counter set next-ac heap-ac set - [ set-heap-ac ] each ; + dup inputs [ set-heap-ac ] each ; GENERIC: analyze-aliases* ( insn -- insn' ) @@ -280,9 +282,10 @@ M: insn eliminate-dead-stores* ; [ insn# set eliminate-dead-stores* ] map-index sift ; : alias-analysis-step ( insns -- insns' ) + init-alias-analysis analyze-aliases compute-live-stores eliminate-dead-stores ; : alias-analysis ( cfg -- cfg' ) - [ init-alias-analysis ] [ alias-analysis-step ] local-optimization ; \ No newline at end of file + [ alias-analysis-step ] local-optimization ; \ No newline at end of file diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 49ea775600..2f8077be99 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel compiler.cfg.instructions compiler.cfg.rpo -compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.liveness +compiler.cfg.def-use compiler.cfg.linearization combinators.short-circuit accessors math sequences sets assocs ; IN: compiler.cfg.checker @@ -54,8 +54,6 @@ ERROR: undefined-values uses defs ; 2dup subset? [ 2drop ] [ undefined-values ] if ; : check-cfg ( cfg -- ) - compute-liveness - [ entry>> live-in assoc-empty? [ bad-live-in ] unless ] [ [ check-basic-block ] each-basic-block ] [ flatten-cfg check-mr ] - tri ; + bi ; diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor index 975adfa6cb..c38f43da8a 100644 --- a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -20,7 +20,7 @@ MIXIN: dataflow-analysis GENERIC# compute-in-set 2 ( bb out-sets dfa -- set ) -M: kill-block compute-in-set 3drop f ; +! M: kill-block compute-in-set 3drop f ; M:: basic-block compute-in-set ( bb out-sets dfa -- set ) bb dfa predecessors [ out-sets at ] map dfa join-sets ; @@ -31,7 +31,7 @@ M:: basic-block compute-in-set ( bb out-sets dfa -- set ) GENERIC# compute-out-set 2 ( bb out-sets dfa -- set ) -M: kill-block compute-out-set 3drop f ; +! M: kill-block compute-out-set 3drop f ; M:: basic-block compute-out-set ( bb in-sets dfa -- set ) bb in-sets at bb dfa transfer-set ; diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index e355ee2ac1..18f1b3be76 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -7,7 +7,7 @@ parser compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.linearization compiler.cfg.registers compiler.cfg.stack-frame compiler.cfg.linear-scan compiler.cfg.two-operand -compiler.cfg.liveness compiler.cfg.optimizer +compiler.cfg.optimizer compiler.cfg.mr compiler.cfg ; IN: compiler.cfg.debugger diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index c8a9d1861b..d7bfc56b32 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel assocs compiler.cfg.instructions ; +USING: accessors arrays kernel assocs sequences +sets compiler.cfg.instructions ; IN: compiler.cfg.def-use GENERIC: defs-vregs ( insn -- seq ) @@ -62,3 +63,12 @@ UNION: vreg-insn _conditional-branch _compare-imm-branch _dispatch ; + +: map-unique ( seq quot -- assoc ) + map concat unique ; inline + +: gen-set ( instructions -- seq ) + [ uses-vregs ] map-unique ; + +: kill-set ( instructions -- seq ) + [ defs-vregs ] map-unique ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 98deca9472..952feb5919 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -4,14 +4,15 @@ USING: accessors kernel math assocs namespaces sequences heaps fry make combinators sets locals cpu.architecture compiler.cfg +compiler.cfg.rpo compiler.cfg.def-use -compiler.cfg.liveness compiler.cfg.registers compiler.cfg.instructions compiler.cfg.linear-scan.mapping compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state -compiler.cfg.linear-scan.live-intervals ; +compiler.cfg.linear-scan.live-intervals +compiler.cfg.linear-scan.liveness ; IN: compiler.cfg.linear-scan.assignment ! This contains both active and inactive intervals; any interval @@ -185,6 +186,6 @@ ERROR: bad-vreg vreg ; ] V{ } make ] change-instructions drop ; -: assign-registers ( live-intervals rpo -- ) +: assign-registers ( live-intervals cfg -- ) [ init-assignment ] dip - [ assign-registers-in-block ] each ; + [ assign-registers-in-block ] each-basic-block ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index df521c1988..7362d185b4 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -7,7 +7,6 @@ compiler.cfg compiler.cfg.optimizer compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.liveness compiler.cfg.predecessors compiler.cfg.rpo compiler.cfg.linearization @@ -1507,9 +1506,7 @@ SYMBOL: linear-scan-result [ cfg new 0 get >>entry compute-predecessors - compute-liveness - dup reverse-post-order - { { int-regs regs } } (linear-scan) + dup { { int-regs regs } } (linear-scan) cfg-changed flatten-cfg 1array mr. ] with-scope ; @@ -2331,9 +2328,6 @@ test-diamond ! early in bootstrap on x86-32 [ t ] [ [ - H{ } clone live-ins set - H{ } clone live-outs set - H{ } clone phi-live-ins set T{ basic-block { id 12345 } { instructions @@ -2353,7 +2347,8 @@ test-diamond T{ ##replace f V int-regs 5 D 0 } } } - } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan) + } cfg new over >>entry + { { int-regs V{ 0 1 2 3 } } } (linear-scan) instructions>> first live-values>> assoc-empty? ] with-scope diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index c17aa23e83..186a773355 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -6,6 +6,7 @@ compiler.cfg compiler.cfg.rpo compiler.cfg.instructions compiler.cfg.linear-scan.numbering +compiler.cfg.linear-scan.liveness compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state @@ -28,17 +29,18 @@ IN: compiler.cfg.linear-scan ! by Omri Traub, Glenn Holloway, Michael D. Smith ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435 -:: (linear-scan) ( rpo machine-registers -- ) - rpo number-instructions - rpo compute-live-intervals machine-registers allocate-registers - rpo assign-registers - rpo resolve-data-flow - rpo check-numbering ; +:: (linear-scan) ( cfg machine-registers -- ) + cfg compute-live-sets + cfg number-instructions + cfg compute-live-intervals machine-registers allocate-registers + cfg assign-registers + cfg resolve-data-flow + cfg check-numbering ; : linear-scan ( cfg -- cfg' ) [ init-mapping - dup reverse-post-order machine-registers (linear-scan) + dup machine-registers (linear-scan) spill-counts get >>spill-counts cfg-changed ] with-scope ; diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 68a780d42a..244f2bc069 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs accessors sequences math math.order fry combinators binary-search compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ; +compiler.cfg.def-use compiler.cfg.linear-scan.liveness compiler.cfg.rpo +compiler.cfg ; IN: compiler.cfg.linear-scan.live-intervals TUPLE: live-range from to ; @@ -144,10 +145,10 @@ ERROR: bad-live-interval live-interval ; } cleave ] each ; -: compute-live-intervals ( rpo -- live-intervals ) +: compute-live-intervals ( cfg -- live-intervals ) H{ } clone [ live-intervals set - [ compute-live-intervals-step ] each + post-order [ compute-live-intervals-step ] each ] keep values dup finish-live-intervals ; : relevant-ranges ( interval1 interval2 -- ranges1 ranges2 ) diff --git a/basis/compiler/cfg/linear-scan/liveness/liveness.factor b/basis/compiler/cfg/linear-scan/liveness/liveness.factor new file mode 100644 index 0000000000..ac36fca9c7 --- /dev/null +++ b/basis/compiler/cfg/linear-scan/liveness/liveness.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors assocs compiler.cfg.def-use +compiler.cfg.dataflow-analysis ; +IN: compiler.cfg.linear-scan.liveness + +! See http://en.wikipedia.org/wiki/Liveness_analysis + +BACKWARD-ANALYSIS: live + +M: live-analysis transfer-set + drop instructions>> + [ gen-set assoc-union ] keep + kill-set assoc-diff ; + +M: live-analysis join-sets + drop assoc-combine ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor index ac18b0cb2e..2976680857 100644 --- a/basis/compiler/cfg/linear-scan/numbering/numbering.factor +++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors math sequences grouping namespaces ; +USING: kernel accessors math sequences grouping namespaces +compiler.cfg.rpo ; IN: compiler.cfg.linear-scan.numbering : number-instructions ( rpo -- ) @@ -8,7 +9,7 @@ IN: compiler.cfg.linear-scan.numbering instructions>> [ [ (>>insn#) ] [ drop 2 + ] 2bi ] each - ] each drop ; + ] each-basic-block drop ; SYMBOL: check-numbering? @@ -18,5 +19,5 @@ ERROR: bad-numbering bb ; dup instructions>> [ insn#>> ] map sift [ <= ] monotonic? [ drop ] [ bad-numbering ] if ; -: check-numbering ( rpo -- ) - check-numbering? get [ [ check-block-numbering ] each ] [ drop ] if ; \ No newline at end of file +: check-numbering ( cfg -- ) + check-numbering? get [ [ check-block-numbering ] each-basic-block ] [ drop ] if ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index f7ed994f18..5bab261ea8 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -3,10 +3,12 @@ USING: accessors arrays assocs combinators combinators.short-circuit fry kernel locals make math sequences +compiler.cfg.rpo compiler.cfg.utilities compiler.cfg.instructions compiler.cfg.linear-scan.assignment -compiler.cfg.linear-scan.mapping compiler.cfg.liveness ; +compiler.cfg.linear-scan.mapping +compiler.cfg.linear-scan.liveness ; IN: compiler.cfg.linear-scan.resolve : add-mapping ( from to reg-class -- ) @@ -43,5 +45,5 @@ IN: compiler.cfg.linear-scan.resolve : resolve-block-data-flow ( bb -- ) dup successors>> [ resolve-edge-data-flow ] with each ; -: resolve-data-flow ( rpo -- ) - [ resolve-block-data-flow ] each ; +: resolve-data-flow ( cfg -- ) + [ resolve-block-data-flow ] each-basic-block ; diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 9faa1e9e38..c62d4b0208 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -4,7 +4,6 @@ USING: kernel math accessors sequences namespaces make combinators assocs arrays locals cpu.architecture compiler.cfg compiler.cfg.rpo -compiler.cfg.liveness compiler.cfg.comparisons compiler.cfg.stack-frame compiler.cfg.instructions ; diff --git a/basis/compiler/cfg/liveness/authors.txt b/basis/compiler/cfg/liveness/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/compiler/cfg/liveness/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/liveness/liveness-tests.factor b/basis/compiler/cfg/liveness/liveness-tests.factor deleted file mode 100644 index 271dc60d76..0000000000 --- a/basis/compiler/cfg/liveness/liveness-tests.factor +++ /dev/null @@ -1,15 +0,0 @@ -USING: compiler.cfg compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.liveness accessors tools.test cpu.architecture ; -IN: compiler.cfg.liveness.tests - -[ - H{ - { "A" H{ { V int-regs 1 V int-regs 1 } { V int-regs 4 V int-regs 4 } } } - { "B" H{ { V int-regs 3 V int-regs 3 } { V int-regs 2 V int-regs 2 } } } - } -] [ - V{ - T{ ##phi f V int-regs 0 { { "A" V int-regs 1 } { "B" V int-regs 2 } } } - T{ ##phi f V int-regs 1 { { "B" V int-regs 3 } { "A" V int-regs 4 } } } - } >>instructions compute-phi-live-in -] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor deleted file mode 100644 index 9dc320660c..0000000000 --- a/basis/compiler/cfg/liveness/liveness.factor +++ /dev/null @@ -1,79 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces deques accessors sets sequences assocs fry -hashtables dlists compiler.cfg.def-use compiler.cfg.instructions -compiler.cfg.rpo ; -IN: compiler.cfg.liveness - -! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis - -! Assoc mapping basic blocks to sets of vregs -SYMBOL: live-ins - -: live-in ( basic-block -- set ) live-ins get at ; - -! Assoc mapping basic blocks to sequences of sets of vregs; each sequence -! is in conrrespondence with a predecessor -SYMBOL: phi-live-ins - -: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ; - -! Assoc mapping basic blocks to sets of vregs -SYMBOL: live-outs - -: live-out ( basic-block -- set ) live-outs get at ; - -SYMBOL: work-list - -: add-to-work-list ( basic-blocks -- ) - work-list get '[ _ push-front ] each ; - -: map-unique ( seq quot -- assoc ) - map concat unique ; inline - -: gen-set ( instructions -- seq ) - [ ##phi? not ] filter [ uses-vregs ] map-unique ; - -: kill-set ( instructions -- seq ) - [ [ defs-vregs ] [ temp-vregs ] bi append ] map-unique ; - -: compute-live-in ( basic-block -- live-in ) - dup instructions>> - [ [ live-out ] [ gen-set ] bi* assoc-union ] - [ nip kill-set ] - 2bi assoc-diff ; - -: compute-phi-live-in ( basic-block -- phi-live-in ) - instructions>> [ ##phi? ] filter [ f ] [ - H{ } clone [ - '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each - ] keep - ] if-empty ; - -: update-live-in ( basic-block -- changed? ) - [ [ compute-live-in ] keep live-ins get maybe-set-at ] - [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ] - bi and ; - -: compute-live-out ( basic-block -- live-out ) - [ successors>> [ live-in ] map ] - [ dup successors>> [ phi-live-in ] with map ] bi - append assoc-combine ; - -: update-live-out ( basic-block -- changed? ) - [ compute-live-out ] keep - live-outs get maybe-set-at ; - -: liveness-step ( basic-block -- ) - dup update-live-out [ - dup update-live-in - [ predecessors>> add-to-work-list ] [ drop ] if - ] [ drop ] if ; - -: compute-liveness ( cfg -- cfg' ) - work-list set - H{ } clone live-ins set - H{ } clone phi-live-ins set - H{ } clone live-outs set - dup post-order add-to-work-list - work-list get [ liveness-step ] slurp-deque ; diff --git a/basis/compiler/cfg/local/authors.txt b/basis/compiler/cfg/local/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/compiler/cfg/local/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/local/local.factor b/basis/compiler/cfg/local/local.factor deleted file mode 100644 index 2f5f5b18e3..0000000000 --- a/basis/compiler/cfg/local/local.factor +++ /dev/null @@ -1,14 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: locals accessors kernel assocs namespaces -compiler.cfg compiler.cfg.liveness compiler.cfg.rpo ; -IN: compiler.cfg.local - -:: optimize-basic-block ( bb init-quot insn-quot -- ) - bb basic-block set - bb live-in keys init-quot call - bb insn-quot change-instructions drop ; inline - -:: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' ) - cfg [ init-quot insn-quot optimize-basic-block ] each-basic-block - cfg ; inline \ No newline at end of file diff --git a/basis/compiler/cfg/mr/mr.factor b/basis/compiler/cfg/mr/mr.factor index 9f6a62090c..cb198d5149 100644 --- a/basis/compiler/cfg/mr/mr.factor +++ b/basis/compiler/cfg/mr/mr.factor @@ -1,13 +1,12 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: compiler.cfg.linearization compiler.cfg.two-operand -compiler.cfg.liveness compiler.cfg.gc-checks compiler.cfg.linear-scan +compiler.cfg.gc-checks compiler.cfg.linear-scan compiler.cfg.build-stack-frame compiler.cfg.rpo ; IN: compiler.cfg.mr : build-mr ( cfg -- mr ) convert-two-operand - compute-liveness insert-gc-checks linear-scan flatten-cfg diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 1af0fcbc53..50148b73b2 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -11,7 +11,6 @@ compiler.cfg.alias-analysis compiler.cfg.value-numbering compiler.cfg.dce compiler.cfg.write-barrier -compiler.cfg.liveness compiler.cfg.rpo compiler.cfg.phi-elimination compiler.cfg.checker ; @@ -35,7 +34,6 @@ SYMBOL: check-optimizer? join-blocks compute-predecessors stack-analysis - compute-liveness alias-analysis value-numbering compute-predecessors diff --git a/basis/compiler/cfg/renaming/renaming.factor b/basis/compiler/cfg/renaming/renaming.factor index 8dbcadfe8b..a2204fb36e 100644 --- a/basis/compiler/cfg/renaming/renaming.factor +++ b/basis/compiler/cfg/renaming/renaming.factor @@ -6,7 +6,7 @@ IN: compiler.cfg.renaming SYMBOL: renamings -: rename-value ( vreg -- vreg' ) renamings get at ; +: rename-value ( vreg -- vreg' ) renamings get ?at drop ; GENERIC: rename-insn-defs ( insn -- ) diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index f6a40e17d0..1ddacdf8ab 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -33,3 +33,10 @@ SYMBOL: visited : each-basic-block ( cfg quot -- ) [ reverse-post-order ] dip each ; inline + +: optimize-basic-block ( bb quot -- ) + [ drop basic-block set ] + [ change-instructions drop ] 2bi ; inline + +: local-optimization ( cfg quot: ( insns -- insns' ) -- cfg' ) + dupd '[ _ optimize-basic-block ] each-basic-block ; inline \ No newline at end of file diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index 87be509c6f..0a52aa7c1a 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences make compiler.cfg.instructions -compiler.cfg.local cpu.architecture ; +compiler.cfg.rpo cpu.architecture ; IN: compiler.cfg.two-operand ! On x86, instructions take the form x = x op y @@ -54,7 +54,6 @@ M: insn convert-two-operand* , ; : convert-two-operand ( cfg -- cfg' ) two-operand? [ - [ drop ] [ [ [ convert-two-operand* ] each ] V{ } make ] local-optimization ] when ; diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor index 76ad3d892f..87fa959178 100644 --- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor +++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor @@ -6,7 +6,6 @@ compiler.cfg.value-numbering.graph ; IN: compiler.cfg.value-numbering.expressions ! Referentially-transparent expressions -TUPLE: expr op ; TUPLE: unary-expr < expr in ; TUPLE: binary-expr < expr in1 in2 ; TUPLE: commutative-expr < binary-expr ; @@ -37,17 +36,6 @@ M: reference-expr equal? } cond ] [ 2drop f ] if ; -! Expressions whose values are inputs to the basic block. We -! can eliminate a second computation having the same 'n' as -! the first one; we can also eliminate input-exprs whose -! result is not used. -TUPLE: input-expr < expr n ; - -SYMBOL: input-expr-counter - -: next-input-expr ( class -- expr ) - input-expr-counter [ dup 1 + ] change input-expr boa ; - : constant>vn ( constant -- vn ) expr>vn ; inline GENERIC: >expr ( insn -- expr ) @@ -97,7 +85,7 @@ M: ##compare-imm >expr compare-imm>expr ; M: ##compare-float >expr compare>expr ; -M: ##flushable >expr class next-input-expr ; +M: ##flushable >expr drop next-input-expr ; : init-expressions ( -- ) 0 input-expr-counter set ; diff --git a/basis/compiler/cfg/value-numbering/graph/graph.factor b/basis/compiler/cfg/value-numbering/graph/graph.factor index 41e7201953..77b75bd3ac 100644 --- a/basis/compiler/cfg/value-numbering/graph/graph.factor +++ b/basis/compiler/cfg/value-numbering/graph/graph.factor @@ -10,13 +10,24 @@ SYMBOL: vn-counter ! biassoc mapping expressions to value numbers SYMBOL: exprs>vns +TUPLE: expr op ; + : expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ; : vn>expr ( vn -- expr ) exprs>vns get value-at ; +! Expressions whose values are inputs to the basic block. +TUPLE: input-expr < expr n ; + +SYMBOL: input-expr-counter + +: next-input-expr ( -- expr ) + f input-expr-counter counter input-expr boa ; + SYMBOL: vregs>vns -: vreg>vn ( vreg -- vn ) vregs>vns get at ; +: vreg>vn ( vreg -- vn ) + vregs>vns get [ drop next-input-expr expr>vn ] cache ; : vn>vreg ( vn -- vreg ) vregs>vns get value-at ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index bd2bb692b7..9063947ae1 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -3,7 +3,7 @@ USING: compiler.cfg.value-numbering compiler.cfg.instructions compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons cpu.architecture tools.test kernel math combinators.short-circuit accessors sequences compiler.cfg.predecessors locals -compiler.cfg.phi-elimination compiler.cfg.dce compiler.cfg.liveness +compiler.cfg.phi-elimination compiler.cfg.dce compiler.cfg assocs vectors arrays layouts namespaces ; : trim-temps ( insns -- insns ) @@ -15,10 +15,6 @@ compiler.cfg assocs vectors arrays layouts namespaces ; } 1|| [ f >>temp ] when ] map ; -: test-value-numbering ( insns -- insns ) - { } init-value-numbering - value-numbering-step ; - ! Folding constants together [ { @@ -33,7 +29,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##load-reference f V int-regs 1 -0.0 } T{ ##replace f V int-regs 0 D 0 } T{ ##replace f V int-regs 1 D 1 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -49,7 +45,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##load-reference f V int-regs 1 0.0 } T{ ##replace f V int-regs 0 D 0 } T{ ##replace f V int-regs 1 D 1 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -65,7 +61,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##load-reference f V int-regs 1 t } T{ ##replace f V int-regs 0 D 0 } T{ ##replace f V int-regs 1 D 1 } - } test-value-numbering + } value-numbering-step ] unit-test ! Copy propagation @@ -80,7 +76,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 45 D 1 } T{ ##copy f V int-regs 48 V int-regs 45 } T{ ##compare-imm-branch f V int-regs 48 7 cc/= } - } test-value-numbering + } value-numbering-step ] unit-test ! Compare propagation @@ -99,7 +95,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= } T{ ##replace f V int-regs 6 D 0 } - } test-value-numbering trim-temps + } value-numbering-step trim-temps ] unit-test [ @@ -117,7 +113,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= } T{ ##replace f V int-regs 6 D 0 } - } test-value-numbering trim-temps + } value-numbering-step trim-temps ] unit-test [ @@ -139,7 +135,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= } T{ ##replace f V int-regs 14 D 0 } - } test-value-numbering trim-temps + } value-numbering-step trim-temps ] unit-test [ @@ -155,7 +151,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 30 D -2 } T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } T{ ##compare-imm-branch f V int-regs 33 5 cc/= } - } test-value-numbering trim-temps + } value-numbering-step trim-temps ] unit-test ! Immediate operand conversion @@ -170,7 +166,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 100 } T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -184,7 +180,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 100 } T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -198,7 +194,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 100 } T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -210,7 +206,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; { T{ ##peek f V int-regs 0 D 0 } T{ ##sub f V int-regs 1 V int-regs 0 V int-regs 0 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -224,7 +220,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 100 } T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -238,7 +234,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 100 } T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -250,7 +246,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; { T{ ##peek f V int-regs 1 D 0 } T{ ##mul-imm f V int-regs 2 V int-regs 1 8 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -264,7 +260,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 100 } T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -278,7 +274,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 100 } T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -292,7 +288,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 100 } T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -306,7 +302,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 100 } T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -320,7 +316,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 100 } T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -334,7 +330,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 100 } T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -348,7 +344,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 100 } T{ ##compare f V int-regs 2 V int-regs 0 V int-regs 1 cc<= } - } test-value-numbering trim-temps + } value-numbering-step trim-temps ] unit-test [ @@ -362,7 +358,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 100 } T{ ##compare f V int-regs 2 V int-regs 1 V int-regs 0 cc<= } - } test-value-numbering trim-temps + } value-numbering-step trim-temps ] unit-test [ @@ -376,7 +372,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 100 } T{ ##compare-branch f V int-regs 0 V int-regs 1 cc<= } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -390,7 +386,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 100 } T{ ##compare-branch f V int-regs 1 V int-regs 0 cc<= } - } test-value-numbering trim-temps + } value-numbering-step trim-temps ] unit-test ! Reassociation @@ -409,7 +405,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 } T{ ##load-immediate f V int-regs 3 50 } T{ ##add f V int-regs 4 V int-regs 2 V int-regs 3 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -427,7 +423,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 } T{ ##load-immediate f V int-regs 3 50 } T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -445,7 +441,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 } T{ ##load-immediate f V int-regs 3 50 } T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -463,7 +459,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 } T{ ##load-immediate f V int-regs 3 50 } T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -481,7 +477,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 } T{ ##load-immediate f V int-regs 3 50 } T{ ##mul f V int-regs 4 V int-regs 2 V int-regs 3 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -499,7 +495,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 } T{ ##load-immediate f V int-regs 3 50 } T{ ##mul f V int-regs 4 V int-regs 3 V int-regs 2 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -517,7 +513,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 } T{ ##load-immediate f V int-regs 3 50 } T{ ##and f V int-regs 4 V int-regs 2 V int-regs 3 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -535,7 +531,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 } T{ ##load-immediate f V int-regs 3 50 } T{ ##and f V int-regs 4 V int-regs 3 V int-regs 2 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -553,7 +549,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 } T{ ##load-immediate f V int-regs 3 50 } T{ ##or f V int-regs 4 V int-regs 2 V int-regs 3 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -571,7 +567,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 } T{ ##load-immediate f V int-regs 3 50 } T{ ##or f V int-regs 4 V int-regs 3 V int-regs 2 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -589,7 +585,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 } T{ ##load-immediate f V int-regs 3 50 } T{ ##xor f V int-regs 4 V int-regs 2 V int-regs 3 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -607,7 +603,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 } T{ ##load-immediate f V int-regs 3 50 } T{ ##xor f V int-regs 4 V int-regs 3 V int-regs 2 } - } test-value-numbering + } value-numbering-step ] unit-test ! Simplification @@ -626,7 +622,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 } T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } T{ ##replace f V int-regs 3 D 0 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -644,7 +640,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 } T{ ##sub f V int-regs 3 V int-regs 0 V int-regs 2 } T{ ##replace f V int-regs 3 D 0 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -662,7 +658,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 } T{ ##or f V int-regs 3 V int-regs 0 V int-regs 2 } T{ ##replace f V int-regs 3 D 0 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -680,7 +676,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 } T{ ##xor f V int-regs 3 V int-regs 0 V int-regs 2 } T{ ##replace f V int-regs 3 D 0 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -696,7 +692,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##load-immediate f V int-regs 1 1 } T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 } T{ ##replace f V int-regs 2 D 0 } - } test-value-numbering + } value-numbering-step ] unit-test ! Constant folding @@ -713,7 +709,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##load-immediate f V int-regs 1 1 } T{ ##load-immediate f V int-regs 2 3 } T{ ##add f V int-regs 3 V int-regs 1 V int-regs 2 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -729,7 +725,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##load-immediate f V int-regs 1 1 } T{ ##load-immediate f V int-regs 2 3 } T{ ##sub f V int-regs 3 V int-regs 1 V int-regs 2 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -745,7 +741,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##load-immediate f V int-regs 1 2 } T{ ##load-immediate f V int-regs 2 3 } T{ ##mul f V int-regs 3 V int-regs 1 V int-regs 2 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -761,7 +757,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##load-immediate f V int-regs 1 2 } T{ ##load-immediate f V int-regs 2 1 } T{ ##and f V int-regs 3 V int-regs 1 V int-regs 2 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -777,7 +773,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##load-immediate f V int-regs 1 2 } T{ ##load-immediate f V int-regs 2 1 } T{ ##or f V int-regs 3 V int-regs 1 V int-regs 2 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -793,7 +789,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##load-immediate f V int-regs 1 2 } T{ ##load-immediate f V int-regs 2 3 } T{ ##xor f V int-regs 3 V int-regs 1 V int-regs 2 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -807,7 +803,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 1 } T{ ##shl-imm f V int-regs 3 V int-regs 1 3 } - } test-value-numbering + } value-numbering-step ] unit-test cell 8 = [ @@ -822,7 +818,7 @@ cell 8 = [ T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 -1 } T{ ##shr-imm f V int-regs 3 V int-regs 1 16 } - } test-value-numbering + } value-numbering-step ] unit-test ] when @@ -837,7 +833,7 @@ cell 8 = [ T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 -8 } T{ ##sar-imm f V int-regs 3 V int-regs 1 1 } - } test-value-numbering + } value-numbering-step ] unit-test cell 8 = [ @@ -854,7 +850,7 @@ cell 8 = [ T{ ##load-immediate f V int-regs 1 65536 } T{ ##shl-imm f V int-regs 2 V int-regs 1 31 } T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -868,7 +864,7 @@ cell 8 = [ T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 2 140737488355328 } T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -884,7 +880,7 @@ cell 8 = [ T{ ##load-immediate f V int-regs 2 2147483647 } T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 } - } test-value-numbering + } value-numbering-step ] unit-test ] when @@ -900,7 +896,7 @@ cell 8 = [ T{ ##load-immediate f V int-regs 1 1 } T{ ##load-immediate f V int-regs 2 2 } T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc= } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -914,7 +910,7 @@ cell 8 = [ T{ ##load-immediate f V int-regs 1 1 } T{ ##load-immediate f V int-regs 2 2 } T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc/= } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -928,7 +924,7 @@ cell 8 = [ T{ ##load-immediate f V int-regs 1 1 } T{ ##load-immediate f V int-regs 2 2 } T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc< } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -942,7 +938,7 @@ cell 8 = [ T{ ##load-immediate f V int-regs 1 1 } T{ ##load-immediate f V int-regs 2 2 } T{ ##compare f V int-regs 3 V int-regs 2 V int-regs 1 cc< } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -954,7 +950,7 @@ cell 8 = [ { T{ ##peek f V int-regs 0 D 0 } T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc< } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -966,7 +962,7 @@ cell 8 = [ { T{ ##peek f V int-regs 0 D 0 } T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -978,7 +974,7 @@ cell 8 = [ { T{ ##peek f V int-regs 0 D 0 } T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc> } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -990,7 +986,7 @@ cell 8 = [ { T{ ##peek f V int-regs 0 D 0 } T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc>= } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -1002,7 +998,7 @@ cell 8 = [ { T{ ##peek f V int-regs 0 D 0 } T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc/= } - } test-value-numbering + } value-numbering-step ] unit-test [ @@ -1014,12 +1010,12 @@ cell 8 = [ { T{ ##peek f V int-regs 0 D 0 } T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc= } - } test-value-numbering + } value-numbering-step ] unit-test : test-branch-folding ( insns -- insns' n ) - [ V{ 0 1 } clone >>successors basic-block set test-value-numbering ] keep + [ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep successors>> first ; [ @@ -1208,7 +1204,6 @@ test-diamond [ ] [ cfg new 0 get >>entry - compute-liveness value-numbering compute-predecessors eliminate-phis drop @@ -1253,7 +1248,6 @@ test-diamond [ ] [ cfg new 0 get >>entry compute-predecessors - compute-liveness value-numbering compute-predecessors eliminate-dead-code @@ -1324,7 +1318,7 @@ V{ [ ] [ cfg new 0 get >>entry - compute-liveness value-numbering eliminate-dead-code drop + value-numbering eliminate-dead-code drop ] unit-test [ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index e49555e06e..0c9616b4e5 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -3,8 +3,7 @@ USING: namespaces assocs biassocs classes kernel math accessors sorting sets sequences fry compiler.cfg -compiler.cfg.local -compiler.cfg.liveness +compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.expressions @@ -13,15 +12,6 @@ compiler.cfg.value-numbering.rewrite ; IN: compiler.cfg.value-numbering ! Local value numbering. Predecessors must be recomputed after this - -: number-input-values ( live-in -- ) - [ [ f next-input-expr simplify ] dip set-vn ] each ; - -: init-value-numbering ( live-in -- ) - init-value-graph - init-expressions - number-input-values ; - : vreg>vreg-mapping ( -- assoc ) vregs>vns get [ keys ] keep '[ dup _ [ at ] [ value-at ] bi ] H{ } map>assoc ; @@ -32,8 +22,10 @@ IN: compiler.cfg.value-numbering ] with-variable ; : value-numbering-step ( insns -- insns' ) - [ rewrite ] map dup rename-uses ; + init-value-graph + init-expressions + [ rewrite ] map + dup rename-uses ; : value-numbering ( cfg -- cfg' ) - [ init-value-numbering ] [ value-numbering-step ] local-optimization - cfg-changed ; + [ value-numbering-step ] local-optimization cfg-changed ; diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index b260b0464e..bcec542501 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors namespaces assocs sets sequences locals compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop -compiler.cfg.liveness compiler.cfg.local ; +compiler.cfg.rpo ; IN: compiler.cfg.write-barrier ! Eliminate redundant write barrier hits. @@ -43,4 +43,4 @@ M: insn eliminate-write-barrier ; [ eliminate-write-barrier ] map sift ; : eliminate-write-barriers ( cfg -- cfg' ) - [ drop ] [ write-barriers-step ] local-optimization ; + [ write-barriers-step ] local-optimization ; From 1e5ce413647e9bddbe8b031dacc45fe17d570347 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 03:26:27 -0500 Subject: [PATCH 15/52] Fix bootstrap --- basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor | 4 ++-- basis/compiler/cfg/dcn/dcn-tests.factor | 1 - basis/compiler/cfg/dcn/global/global.factor | 4 ---- 3 files changed, 2 insertions(+), 7 deletions(-) diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor index c38f43da8a..975adfa6cb 100644 --- a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -20,7 +20,7 @@ MIXIN: dataflow-analysis GENERIC# compute-in-set 2 ( bb out-sets dfa -- set ) -! M: kill-block compute-in-set 3drop f ; +M: kill-block compute-in-set 3drop f ; M:: basic-block compute-in-set ( bb out-sets dfa -- set ) bb dfa predecessors [ out-sets at ] map dfa join-sets ; @@ -31,7 +31,7 @@ M:: basic-block compute-in-set ( bb out-sets dfa -- set ) GENERIC# compute-out-set 2 ( bb out-sets dfa -- set ) -! M: kill-block compute-out-set 3drop f ; +M: kill-block compute-out-set 3drop f ; M:: basic-block compute-out-set ( bb in-sets dfa -- set ) bb in-sets at bb dfa transfer-set ; diff --git a/basis/compiler/cfg/dcn/dcn-tests.factor b/basis/compiler/cfg/dcn/dcn-tests.factor index 43a66a8012..3dfaa665aa 100644 --- a/basis/compiler/cfg/dcn/dcn-tests.factor +++ b/basis/compiler/cfg/dcn/dcn-tests.factor @@ -13,7 +13,6 @@ compiler.cfg.dcn.height compiler.cfg.dcn.local compiler.cfg.dcn.local.private compiler.cfg.dcn.global -compiler.cfg.dcn.global.private compiler.cfg.dcn.rewrite ; : test-local-dcn ( insns -- insns' ) diff --git a/basis/compiler/cfg/dcn/global/global.factor b/basis/compiler/cfg/dcn/global/global.factor index 44f8af24cc..21a795151a 100644 --- a/basis/compiler/cfg/dcn/global/global.factor +++ b/basis/compiler/cfg/dcn/global/global.factor @@ -4,8 +4,6 @@ USING: assocs kernel combinators compiler.cfg.dataflow-analysis compiler.cfg.dcn.local ; IN: compiler.cfg.dcn.global - - ! Main word : compute-global-sets ( cfg -- ) { From 44bcd258f6721b631b8e4c5ac567a38cb1e7d02a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 06:05:17 -0500 Subject: [PATCH 16/52] Insert _loop-entry in linearization pass instead of in CFG builder, so that optimizations don't have to worry about it --- basis/compiler/cfg/builder/builder.factor | 1 - basis/compiler/cfg/checker/checker.factor | 20 +++++++------------ .../cfg/instructions/instructions.factor | 3 +-- .../cfg/linearization/linearization.factor | 15 +++++++++----- .../cfg/optimizer/optimizer-tests.factor | 12 +++++------ basis/compiler/cfg/optimizer/optimizer.factor | 2 -- basis/compiler/codegen/codegen.factor | 2 +- 7 files changed, 25 insertions(+), 30 deletions(-) diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index e3c502e66e..48162156c8 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -86,7 +86,6 @@ GENERIC: emit-node ( node -- ) basic-block get swap loops get set-at ; : emit-loop ( node -- ) - ##loop-entry ##branch begin-basic-block [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ; diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 60b8ed4118..f4738c675c 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -2,14 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities -combinators.short-circuit accessors math sequences sets assocs ; +compiler.cfg.mr combinators.short-circuit accessors math sequences +sets assocs ; IN: compiler.cfg.checker ERROR: bad-kill-block bb ; : check-kill-block ( bb -- ) dup instructions>> first2 - swap ##epilogue? [ [ ##return? ] [ ##callback-return? ] bi or ] [ ##branch? ] if + swap ##epilogue? [ + { [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1|| + ] [ ##branch? ] if [ drop ] [ bad-kill-block ] if ; ERROR: last-insn-not-a-jump bb ; @@ -26,14 +29,6 @@ ERROR: last-insn-not-a-jump bb ; [ ##no-tco? ] } 1|| [ drop ] [ last-insn-not-a-jump ] if ; -ERROR: bad-loop-entry bb ; - -: check-loop-entry ( bb -- ) - dup instructions>> dup length 2 >= [ - 2 head* [ ##loop-entry? ] any? - [ bad-loop-entry ] [ drop ] if - ] [ 2drop ] if ; - ERROR: bad-kill-insn bb ; : check-kill-instructions ( bb -- ) @@ -41,10 +36,9 @@ ERROR: bad-kill-insn bb ; [ bad-kill-insn ] [ drop ] if ; : check-normal-block ( bb -- ) - [ check-loop-entry ] [ check-last-instruction ] [ check-kill-instructions ] - tri ; + bi ; ERROR: bad-successors ; @@ -70,5 +64,5 @@ ERROR: undefined-values uses defs ; : check-cfg ( cfg -- ) [ [ check-basic-block ] each-basic-block ] - [ flatten-cfg check-mr ] + [ build-mr check-mr ] bi ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 43d92c9ccc..2496b29ae2 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -170,8 +170,6 @@ INSN: ##epilogue ; INSN: ##branch ; -INSN: ##loop-entry ; - INSN: ##phi < ##pure inputs ; ! Conditionals @@ -201,6 +199,7 @@ INSN: _epilogue stack-frame ; INSN: _label id ; INSN: _branch label ; +INSN: _loop-entry ; INSN: _dispatch src temp ; INSN: _dispatch-label label ; diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index c62d4b0208..1f00913b1e 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -6,7 +6,8 @@ compiler.cfg compiler.cfg.rpo compiler.cfg.comparisons compiler.cfg.stack-frame -compiler.cfg.instructions ; +compiler.cfg.instructions +compiler.cfg.utilities ; IN: compiler.cfg.linearization ! Convert CFG IR to machine IR. @@ -24,7 +25,11 @@ M: insn linearize-insn , drop ; #! don't need to branch. [ number>> ] bi@ 1 - = ; inline -: emit-branch ( basic-block successor -- ) +: emit-loop-entry? ( bb -- ? ) + dup predecessors>> [ swap back-edge? ] with any? ; + +: emit-branch ( bb successor -- ) + dup emit-loop-entry? [ _loop-entry ] when 2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ; M: ##branch linearize-insn @@ -32,11 +37,11 @@ M: ##branch linearize-insn : successors ( bb -- first second ) successors>> first2 ; inline -: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc ) +: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc ) [ dup successors ] [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline -: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc ) +: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc ) [ (binary-conditional) ] [ drop dup successors>> second useless-branch? ] 2bi [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ; @@ -53,7 +58,7 @@ M: ##compare-imm-branch linearize-insn M: ##compare-float-branch linearize-insn [ binary-conditional _compare-float-branch ] with-regs emit-branch ; -: overflow-conditional ( basic-block insn -- basic-block successor label2 dst src1 src2 ) +: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 ) [ dup successors number>> ] [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor index 1eb1996da4..695a586199 100755 --- a/basis/compiler/cfg/optimizer/optimizer-tests.factor +++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor @@ -1,8 +1,8 @@ -USING: accessors arrays compiler.cfg.checker -compiler.cfg.debugger compiler.cfg.def-use -compiler.cfg.instructions fry kernel kernel.private math -math.partial-dispatch math.private sbufs sequences sequences.private sets -slots.private strings strings.private tools.test vectors layouts ; +USING: accessors arrays compiler.cfg.checker compiler.cfg.debugger +compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.optimizer +fry kernel kernel.private math math.partial-dispatch math.private +sbufs sequences sequences.private sets slots.private strings +strings.private tools.test vectors layouts ; IN: compiler.cfg.optimizer.tests ! Miscellaneous tests @@ -45,7 +45,7 @@ IN: compiler.cfg.optimizer.tests set-string-nth-fast ] } [ - [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test + [ [ ] ] dip '[ _ test-cfg first optimize-cfg check-cfg ] unit-test ] each cell 8 = [ diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index af73fd9420..1419ff1952 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -5,7 +5,6 @@ compiler.cfg.tco compiler.cfg.predecessors compiler.cfg.useless-conditionals compiler.cfg.dcn -compiler.cfg.dominance compiler.cfg.ssa compiler.cfg.branch-splitting compiler.cfg.block-joining @@ -36,7 +35,6 @@ SYMBOL: check-optimizer? join-blocks compute-predecessors deconcatenatize - compute-dominance construct-ssa alias-analysis value-numbering diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 5df0114244..f1052da2d5 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -245,7 +245,7 @@ M: _gc generate-insn [ gc-root-count>> ] } cleave %gc ; -M: ##loop-entry generate-insn drop %loop-entry ; +M: _loop-entry generate-insn drop %loop-entry ; M: ##alien-global generate-insn [ dst>> register ] [ symbol>> ] [ library>> ] tri From 31491df5f1c551a5262e16d273b49acea8b9d6d9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 06:05:33 -0500 Subject: [PATCH 17/52] Removed unused code from compiler.cfg.def-use --- basis/compiler/cfg/def-use/def-use.factor | 9 --------- 1 file changed, 9 deletions(-) diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 1c52c081a1..0f488de559 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -49,12 +49,3 @@ M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: _compare-imm-branch uses-vregs src1>> 1array ; M: _dispatch uses-vregs src>> 1array ; M: insn uses-vregs drop f ; - -: map-unique ( seq quot -- assoc ) - map concat unique ; inline - -: gen-set ( instructions -- seq ) - [ uses-vregs ] map-unique ; - -: kill-set ( instructions -- seq ) - [ defs-vregs ] map-unique ; From 89db2e745d08f2c51a0df07dafbcf8ea774b7eeb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 06:07:28 -0500 Subject: [PATCH 18/52] Move liveness back to compiler.cfg.liveness, fix a corner-case where it didn't work on some forms of non-SSA code --- .../cfg/alias-analysis/alias-analysis.factor | 7 +--- .../linear-scan/assignment/assignment.factor | 4 +- .../cfg/linear-scan/linear-scan.factor | 2 +- .../live-intervals/live-intervals.factor | 2 +- .../cfg/linear-scan/liveness/liveness.factor | 17 --------- .../cfg/linear-scan/resolve/resolve.factor | 4 +- .../cfg/liveness/liveness-tests.factor | 38 +++++++++++++++++++ basis/compiler/cfg/liveness/liveness.factor | 26 +++++++++++++ 8 files changed, 72 insertions(+), 28 deletions(-) delete mode 100644 basis/compiler/cfg/linear-scan/liveness/liveness.factor create mode 100644 basis/compiler/cfg/liveness/liveness-tests.factor create mode 100644 basis/compiler/cfg/liveness/liveness.factor diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 78e271c1f6..f6834c131d 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -3,7 +3,7 @@ USING: kernel math namespaces assocs hashtables sequences arrays accessors vectors combinators sets classes compiler.cfg compiler.cfg.registers compiler.cfg.instructions -compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.def-use ; +compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.liveness ; IN: compiler.cfg.alias-analysis ! We try to eliminate redundant slot operations using some simple heuristics. @@ -196,9 +196,6 @@ M: ##set-slot insn-object obj>> resolve ; M: ##set-slot-imm insn-object obj>> resolve ; M: ##alien-global insn-object drop \ ##alien-global ; -: inputs ( insns -- seq ) - [ [ ##phi? not ] filter gen-set ] [ kill-set ] bi assoc-diff keys ; - : init-alias-analysis ( insns -- insns' ) H{ } clone histories set H{ } clone vregs>acs set @@ -210,7 +207,7 @@ M: ##alien-global insn-object drop \ ##alien-global ; 0 ac-counter set next-ac heap-ac set - dup inputs [ set-heap-ac ] each ; + dup local-live-in [ set-heap-ac ] each ; GENERIC: analyze-aliases* ( insn -- insn' ) diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 952feb5919..8e21e7e3fb 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -6,13 +6,13 @@ cpu.architecture compiler.cfg compiler.cfg.rpo compiler.cfg.def-use +compiler.cfg.liveness compiler.cfg.registers compiler.cfg.instructions compiler.cfg.linear-scan.mapping compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state -compiler.cfg.linear-scan.live-intervals -compiler.cfg.linear-scan.liveness ; +compiler.cfg.linear-scan.live-intervals ; IN: compiler.cfg.linear-scan.assignment ! This contains both active and inactive intervals; any interval diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index 186a773355..b081f2ca6e 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -4,9 +4,9 @@ USING: kernel accessors namespaces make locals cpu.architecture compiler.cfg compiler.cfg.rpo +compiler.cfg.liveness compiler.cfg.instructions compiler.cfg.linear-scan.numbering -compiler.cfg.linear-scan.liveness compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 244f2bc069..8813a4e94e 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs accessors sequences math math.order fry combinators binary-search compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.def-use compiler.cfg.linear-scan.liveness compiler.cfg.rpo +compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.rpo compiler.cfg ; IN: compiler.cfg.linear-scan.live-intervals diff --git a/basis/compiler/cfg/linear-scan/liveness/liveness.factor b/basis/compiler/cfg/linear-scan/liveness/liveness.factor deleted file mode 100644 index ac36fca9c7..0000000000 --- a/basis/compiler/cfg/linear-scan/liveness/liveness.factor +++ /dev/null @@ -1,17 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors assocs compiler.cfg.def-use -compiler.cfg.dataflow-analysis ; -IN: compiler.cfg.linear-scan.liveness - -! See http://en.wikipedia.org/wiki/Liveness_analysis - -BACKWARD-ANALYSIS: live - -M: live-analysis transfer-set - drop instructions>> - [ gen-set assoc-union ] keep - kill-set assoc-diff ; - -M: live-analysis join-sets - drop assoc-combine ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 5bab261ea8..56beaa5379 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -4,11 +4,11 @@ USING: accessors arrays assocs combinators combinators.short-circuit fry kernel locals make math sequences compiler.cfg.rpo +compiler.cfg.liveness compiler.cfg.utilities compiler.cfg.instructions compiler.cfg.linear-scan.assignment -compiler.cfg.linear-scan.mapping -compiler.cfg.linear-scan.liveness ; +compiler.cfg.linear-scan.mapping ; IN: compiler.cfg.linear-scan.resolve : add-mapping ( from to reg-class -- ) diff --git a/basis/compiler/cfg/liveness/liveness-tests.factor b/basis/compiler/cfg/liveness/liveness-tests.factor new file mode 100644 index 0000000000..697a1f8a7b --- /dev/null +++ b/basis/compiler/cfg/liveness/liveness-tests.factor @@ -0,0 +1,38 @@ +USING: compiler.cfg.liveness compiler.cfg.debugger +compiler.cfg.instructions compiler.cfg.predecessors +compiler.cfg.registers compiler.cfg cpu.architecture +accessors namespaces sequences kernel tools.test ; +IN: compiler.cfg.liveness.tests + +! Sanity check... + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f V int-regs 1 D 1 } + T{ ##peek f V int-regs 1 D 1 } +} 1 test-bb + +V{ + T{ ##replace f V int-regs 2 D 0 } +} 2 test-bb + +V{ + T{ ##replace f V int-regs 3 D 0 } +} 3 test-bb + +1 get 2 get 3 get V{ } 2sequence >>successors drop + +cfg new 1 get >>entry +compute-predecessors +compute-live-sets + +[ + H{ + { V int-regs 1 V int-regs 1 } + { V int-regs 2 V int-regs 2 } + { V int-regs 3 V int-regs 3 } + } +] +[ 1 get live-in ] +unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor new file mode 100644 index 0000000000..c1793842a2 --- /dev/null +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors assocs sequences sets +compiler.cfg.def-use compiler.cfg.dataflow-analysis +compiler.cfg.instructions ; +IN: compiler.cfg.liveness + +! See http://en.wikipedia.org/wiki/Liveness_analysis +! Do not run after SSA construction + +BACKWARD-ANALYSIS: live + +: transfer-liveness ( live-set instructions -- live-set' ) + [ clone ] [ ] bi* [ + [ uses-vregs [ over conjoin ] each ] + [ defs-vregs [ over delete-at ] each ] bi + ] each ; + +: local-live-in ( instructions -- live-set ) + [ ##phi? not ] filter [ H{ } ] dip transfer-liveness keys ; + +M: live-analysis transfer-set + drop instructions>> transfer-liveness ; + +M: live-analysis join-sets + drop assoc-combine ; \ No newline at end of file From d864214119f2ba18f862b094b4eedb2e29cb6a0c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 06:07:51 -0500 Subject: [PATCH 19/52] compiler.cfg.dominance: add algorithm for computing iterated dominance frontiers --- .../cfg/dominance/dominance-tests.factor | 22 +++++++++++++ basis/compiler/cfg/dominance/dominance.factor | 31 ++++++++++++++++--- 2 files changed, 49 insertions(+), 4 deletions(-) diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor index 210d5614c2..d73871c25f 100644 --- a/basis/compiler/cfg/dominance/dominance-tests.factor +++ b/basis/compiler/cfg/dominance/dominance-tests.factor @@ -74,3 +74,25 @@ V{ } 5 test-bb [ ] [ test-dominance ] unit-test [ t ] [ 0 5 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test + +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ } 4 test-bb +V{ } 5 test-bb +V{ } 6 test-bb + +0 get 1 get 5 get V{ } 2sequence >>successors drop +1 get 2 get 3 get V{ } 2sequence >>successors drop +2 get 4 get 1vector >>successors drop +3 get 4 get 1vector >>successors drop +4 get 6 get 1vector >>successors drop +5 get 6 get 1vector >>successors drop + +[ ] [ test-dominance ] unit-test + +[ t ] [ + 2 get 3 get 2array iterated-dom-frontier + 4 get 6 get 2array set= +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor index 9c8fc79619..73d9f58eec 100644 --- a/basis/compiler/cfg/dominance/dominance.factor +++ b/basis/compiler/cfg/dominance/dominance.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators sets math fry kernel math.order -namespaces sequences sorting compiler.cfg.rpo ; +dlists deques namespaces sequences sorting compiler.cfg.rpo ; IN: compiler.cfg.dominance ! Reference: @@ -85,8 +85,31 @@ PRIVATE> PRIVATE> -: compute-dominance ( cfg -- cfg' ) +: compute-dominance ( cfg -- ) [ compute-dom-parents compute-dom-children ] [ compute-dom-frontiers ] - [ ] - tri ; + bi ; + + + +: iterated-dom-frontier ( bbs -- bbs' ) + [ + work-list set + H{ } clone visited set + [ add-to-work-list ] each + work-list get [ iterated-dom-frontier-step ] slurp-deque + visited get keys + ] with-scope ; \ No newline at end of file From 26a5d51d939ca21c10c1915d22a9ed1647df7314 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 06:08:04 -0500 Subject: [PATCH 20/52] compiler.cfg.ssa: now builds pruned SSA form --- basis/compiler/cfg/ssa/ssa-tests.factor | 44 +++++++++++++++--- basis/compiler/cfg/ssa/ssa.factor | 59 +++++++++---------------- 2 files changed, 61 insertions(+), 42 deletions(-) diff --git a/basis/compiler/cfg/ssa/ssa-tests.factor b/basis/compiler/cfg/ssa/ssa-tests.factor index c53d30af5d..6a3a014f78 100644 --- a/basis/compiler/cfg/ssa/ssa-tests.factor +++ b/basis/compiler/cfg/ssa/ssa-tests.factor @@ -5,9 +5,12 @@ compiler.cfg.registers cpu.architecture kernel namespaces sequences tools.test vectors ; IN: compiler.cfg.ssa.tests -! Reset counters so that results are deterministic w.r.t. hash order -0 vreg-counter set-global -0 basic-block set-global +: reset-counters ( -- ) + ! Reset counters so that results are deterministic w.r.t. hash order + 0 vreg-counter set-global + 0 basic-block set-global ; + +reset-counters V{ T{ ##load-immediate f V int-regs 1 100 } @@ -38,7 +41,6 @@ V{ : test-ssa ( -- ) cfg new 0 get >>entry compute-predecessors - compute-dominance construct-ssa drop ; @@ -67,6 +69,9 @@ V{ } ] [ 2 get instructions>> ] unit-test +: clean-up-phis ( insns -- insns' ) + [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ; + [ V{ T{ ##phi f V int-regs 6 H{ { 1 V int-regs 4 } { 2 V int-regs 5 } } } @@ -75,5 +80,34 @@ V{ } ] [ 3 get instructions>> - [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map + clean-up-phis +] unit-test + +reset-counters + +V{ } 0 test-bb +V{ } 1 test-bb +V{ T{ ##peek f V int-regs 0 D 0 } } 2 test-bb +V{ T{ ##peek f V int-regs 0 D 0 } } 3 test-bb +V{ T{ ##replace f V int-regs 0 D 0 } } 4 test-bb +V{ } 5 test-bb +V{ } 6 test-bb + +0 get 1 get 5 get V{ } 2sequence >>successors drop +1 get 2 get 3 get V{ } 2sequence >>successors drop +2 get 4 get 1vector >>successors drop +3 get 4 get 1vector >>successors drop +4 get 6 get 1vector >>successors drop +5 get 6 get 1vector >>successors drop + +[ ] [ test-ssa ] unit-test + +[ + V{ + T{ ##phi f V int-regs 3 H{ { 2 V int-regs 1 } { 3 V int-regs 2 } } } + T{ ##replace f V int-regs 3 D 0 } + } +] [ + 4 get instructions>> + clean-up-phis ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/ssa.factor b/basis/compiler/cfg/ssa/ssa.factor index e11701965b..2e76ba35a1 100644 --- a/basis/compiler/cfg/ssa/ssa.factor +++ b/basis/compiler/cfg/ssa/ssa.factor @@ -1,19 +1,21 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel accessors sequences fry dlists -deques assocs sets math combinators sorting +USING: namespaces kernel accessors sequences fry assocs +sets math combinators compiler.cfg compiler.cfg.rpo compiler.cfg.def-use compiler.cfg.renaming +compiler.cfg.liveness compiler.cfg.registers compiler.cfg.dominance compiler.cfg.instructions ; IN: compiler.cfg.ssa -! SSA construction. Predecessors and dominance must be computed first. +! SSA construction. Predecessors must be computed first. -! This is the classical algorithm based on dominance frontiers: +! This is the classical algorithm based on dominance frontiers, except +! we consult liveness information to build pruned SSA: ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.25.8240 ! Eventually might be worth trying something fancier: @@ -32,45 +34,22 @@ SYMBOL: inserting-phi-nodes '[ dup instructions>> [ defs-vregs [ - _ push-at + _ conjoin-at ] with each ] with each ] each-basic-block ; -SYMBOLS: has-already ever-on-work-list work-list ; - -: init-insert-phi-nodes ( bbs -- ) - H{ } clone has-already set - [ unique ever-on-work-list set ] - [ [ push-all-front ] keep work-list set ] bi ; - -: add-to-work-list ( bb -- ) - dup ever-on-work-list get key? [ drop ] [ - [ ever-on-work-list get conjoin ] - [ work-list get push-front ] - bi - ] if ; - : insert-phi-node-later ( vreg bb -- ) - [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep - inserting-phi-nodes get push-at ; - -: compute-phi-node-in ( vreg bb -- ) - dup has-already get key? [ 2drop ] [ - [ insert-phi-node-later ] - [ has-already get conjoin ] - [ add-to-work-list ] - tri - ] if ; + 2dup live-in key? [ + [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep + inserting-phi-nodes get push-at + ] [ 2drop ] if ; : compute-phi-nodes-for ( vreg bbs -- ) - dup length 2 >= [ - init-insert-phi-nodes - work-list get [ - dom-frontier [ - compute-phi-node-in - ] with each - ] with slurp-deque + keys dup length 2 >= [ + iterated-dom-frontier [ + insert-phi-node-later + ] with each ] [ 2drop ] if ; : compute-phi-nodes ( -- ) @@ -143,4 +122,10 @@ M: ##phi rename-insn PRIVATE> : construct-ssa ( cfg -- cfg' ) - dup [ compute-defs compute-phi-nodes insert-phi-nodes ] [ rename ] bi ; \ No newline at end of file + { + [ ] + [ compute-live-sets ] + [ compute-dominance ] + [ compute-defs compute-phi-nodes insert-phi-nodes ] + [ rename ] + } cleave ; \ No newline at end of file From 995a96d7e492430c519c008c36297a3eb8c69757 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 06:19:31 -0500 Subject: [PATCH 21/52] compiler.cfg.dominance: fix unit tests --- basis/compiler/cfg/dominance/dominance-tests.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor index d73871c25f..e884e32d78 100644 --- a/basis/compiler/cfg/dominance/dominance-tests.factor +++ b/basis/compiler/cfg/dominance/dominance-tests.factor @@ -6,8 +6,7 @@ compiler.cfg.predecessors ; : test-dominance ( -- ) cfg new 0 get >>entry compute-predecessors - compute-dominance - drop ; + compute-dominance ; ! Example with no back edges V{ } 0 test-bb From ac2c65e92019c3c35bc37958f2b2a0f758da096f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 22 Jul 2009 12:06:30 -0500 Subject: [PATCH 22/52] OR gl extension testing --- .../capabilities/capabilities-docs.factor | 8 ++++++- .../capabilities/capabilities-tests.factor | 21 +++++++++++++++++++ basis/opengl/capabilities/capabilities.factor | 7 +++++-- 3 files changed, 33 insertions(+), 3 deletions(-) create mode 100644 basis/opengl/capabilities/capabilities-tests.factor diff --git a/basis/opengl/capabilities/capabilities-docs.factor b/basis/opengl/capabilities/capabilities-docs.factor index f5424e19da..959b222671 100644 --- a/basis/opengl/capabilities/capabilities-docs.factor +++ b/basis/opengl/capabilities/capabilities-docs.factor @@ -40,7 +40,13 @@ HELP: gl-extensions HELP: has-gl-extensions? { $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } } -{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ; +{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } ". Elements of " { $snippet "extensions" } " can be sequences, in which case true will be returned if any one of the extensions in the subsequence are available." } +{ $examples "Testing for framebuffer object and pixel buffer support:" + { $code <" { + { "GL_EXT_framebuffer_object" "GL_ARB_framebuffer_object" } + "GL_ARB_pixel_buffer_object" +} has-gl-extensions? "> } +} ; HELP: has-gl-version-or-extensions? { $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } } diff --git a/basis/opengl/capabilities/capabilities-tests.factor b/basis/opengl/capabilities/capabilities-tests.factor new file mode 100644 index 0000000000..8bc8871482 --- /dev/null +++ b/basis/opengl/capabilities/capabilities-tests.factor @@ -0,0 +1,21 @@ +! (c)2009 Joe Groff bsd license +USING: opengl.capabilities tools.test ; +IN: opengl.capabilities.tests + +CONSTANT: test-extensions + { + "GL_ARB_vent_core_frogblast" + "GL_EXT_resonance_cascade" + "GL_EXT_slipgate" + } + +[ t ] +[ "GL_ARB_vent_core_frogblast" test-extensions (has-extension?) ] unit-test + +[ f ] +[ "GL_ARB_wallhack" test-extensions (has-extension?) ] unit-test + +[ t ] [ + { "GL_EXT_dimensional_portal" "GL_EXT_slipgate" } + test-extensions (has-extension?) +] unit-test diff --git a/basis/opengl/capabilities/capabilities.factor b/basis/opengl/capabilities/capabilities.factor index ad04ce7fa5..37bfabc19b 100755 --- a/basis/opengl/capabilities/capabilities.factor +++ b/basis/opengl/capabilities/capabilities.factor @@ -1,16 +1,19 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces make sequences splitting opengl.gl -continuations math.parser math arrays sets math.order fry ; +continuations math.parser math arrays sets strings math.order fry ; IN: opengl.capabilities : (require-gl) ( thing require-quot make-error-quot -- ) [ dupd call [ drop ] ] dip '[ _ " " make throw ] if ; inline +: (has-extension?) ( query-extension(s) available-extensions -- ? ) + over string? [ member? ] [ [ member? ] curry any? ] if ; + : gl-extensions ( -- seq ) GL_EXTENSIONS glGetString " " split ; : has-gl-extensions? ( extensions -- ? ) - gl-extensions swap [ over member? ] all? nip ; + gl-extensions [ (has-extension?) ] curry all? ; : (make-gl-extensions-error) ( required-extensions -- ) gl-extensions diff "Required OpenGL extensions not supported:\n" % From 3bbc9835fcf509e3f2e626f46c0e831d06266649 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 22 Jul 2009 12:43:44 -0500 Subject: [PATCH 23/52] add a new "make-tuple" combinator for cleaving values into tuple slots by name. make render-set read-only and update gpu demos to use make-tuple --- extra/combinators/tuple/tuple-docs.factor | 43 ++++++++++++++++++++++ extra/combinators/tuple/tuple.factor | 29 +++++++++++++++ extra/gpu/demos/bunny/bunny.factor | 45 +++++++++++------------ extra/gpu/demos/raytrace/raytrace.factor | 19 +++++----- extra/gpu/render/render.factor | 25 +++++++++---- 5 files changed, 119 insertions(+), 42 deletions(-) create mode 100644 extra/combinators/tuple/tuple-docs.factor create mode 100644 extra/combinators/tuple/tuple.factor diff --git a/extra/combinators/tuple/tuple-docs.factor b/extra/combinators/tuple/tuple-docs.factor new file mode 100644 index 0000000000..aedb013129 --- /dev/null +++ b/extra/combinators/tuple/tuple-docs.factor @@ -0,0 +1,43 @@ +! (c)2009 Joe Groff bsd license +USING: assocs classes help.markup help.syntax kernel math +quotations strings ; +IN: combinators.tuple + +HELP: 2make-tuple +{ $values + { "x" object } { "y" object } { "class" class } { "assoc" assoc } + { "tuple" tuple } +} +{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } " and " { $snippet "y" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y -- slot-value )" } ". The order in which the quotations is called is undefined." } ; + +HELP: 3make-tuple +{ $values + { "x" object } { "y" object } { "z" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" } + { "tuple" tuple } +} +{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", " { $snippet "y" } ", and " { $snippet "z" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y z -- slot-value )" } ". The order in which the quotations is called is undefined." } ; + +HELP: make-tuple +{ $values + { "x" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" } + { "tuple" tuple } +} +{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x -- slot-value )" } ". The order in which the quotations is called is undefined." } ; + +HELP: nmake-tuple +{ $values + { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" } { "n" integer } +} +{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on the top " { $snippet "n" } " values on the datastack below " { $snippet "class" } ", assigning the result of each call to the slot named by the corresponding key. The order in which the quotations is called is undefined." } ; + +{ make-tuple 2make-tuple 3make-tuple nmake-tuple } related-words + +ARTICLE: "combinators.tuple" "Tuple-constructing combinators" +"The " { $vocab-link "combinators.tuple" } " vocabulary provides dataflow combinators that construct " { $link tuple } " objects." +{ $subsection make-tuple } +{ $subsection 2make-tuple } +{ $subsection 3make-tuple } +{ $subsection nmake-tuple } +; + +ABOUT: "combinators.tuple" diff --git a/extra/combinators/tuple/tuple.factor b/extra/combinators/tuple/tuple.factor new file mode 100644 index 0000000000..c4e0ef40a1 --- /dev/null +++ b/extra/combinators/tuple/tuple.factor @@ -0,0 +1,29 @@ +! (c)2009 Joe Groff bsd license +USING: accessors assocs classes.tuple generalizations kernel +locals quotations sequences ; +IN: combinators.tuple + +> assoc at [ + slot initial>> :> initial + { n ndrop initial } >quotation + ] unless* ; + +PRIVATE> + +MACRO:: nmake-tuple ( class assoc n -- ) + class all-slots [ assoc n (tuple-slot-quot) ] map :> quots + class :> \class + { quots n ncleave \class boa } >quotation ; + +: make-tuple ( x class assoc -- tuple ) + 1 nmake-tuple ; inline + +: 2make-tuple ( x y class assoc -- tuple ) + 2 nmake-tuple ; inline + +: 3make-tuple ( x y z class assoc -- tuple ) + 3 nmake-tuple ; inline + diff --git a/extra/gpu/demos/bunny/bunny.factor b/extra/gpu/demos/bunny/bunny.factor index ea15dc7884..a1b42d9f12 100755 --- a/extra/gpu/demos/bunny/bunny.factor +++ b/extra/gpu/demos/bunny/bunny.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff bsd license USING: accessors alien.c-types arrays combinators combinators.short-circuit game-worlds gpu gpu.buffers gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state gpu.textures gpu.util grouping http.client images @@ -229,16 +230,14 @@ BEFORE: bunny-world begin-world { depth-attachment 1.0 } } clear-framebuffer ] [ - render-set new - triangles-mode >>primitive-mode - { T{ color-attachment f 0 } T{ color-attachment f 1 } } >>output-attachments - swap { - [ >>uniforms ] - [ bunny>> vertex-array>> >>vertex-array ] - [ bunny>> index-elements>> >>indexes ] - [ sobel>> framebuffer>> >>framebuffer ] - } cleave - render + { + { "primitive-mode" [ drop triangles-mode ] } + { "output-attachments" [ drop { T{ color-attachment f 0 } T{ color-attachment f 1 } } ] } + { "uniforms" [ ] } + { "vertex-array" [ bunny>> vertex-array>> ] } + { "indexes" [ bunny>> index-elements>> ] } + { "framebuffer" [ sobel>> framebuffer>> ] } + } render ] bi ; : ( sobel -- uniforms ) @@ -250,13 +249,12 @@ BEFORE: bunny-world begin-world : draw-sobel ( world -- ) T{ depth-state { comparison f } } set-gpu-state* - render-set new - triangle-strip-mode >>primitive-mode - T{ index-range f 0 4 } >>indexes - swap sobel>> - [ >>uniforms ] - [ vertex-array>> >>vertex-array ] bi - render ; + sobel>> { + { "primitive-mode" [ drop triangle-strip-mode ] } + { "indexes" [ drop T{ index-range f 0 4 } ] } + { "uniforms" [ ] } + { "vertex-array" [ vertex-array>> ] } + } render ; : draw-sobeled-bunny ( world -- ) [ draw-bunny ] [ draw-sobel ] bi ; @@ -264,13 +262,12 @@ BEFORE: bunny-world begin-world : draw-loading ( world -- ) T{ depth-state { comparison f } } set-gpu-state* - render-set new - triangle-strip-mode >>primitive-mode - T{ index-range f 0 4 } >>indexes - swap loading>> - [ { 1.0 -1.0 } swap texture>> loading-uniforms boa >>uniforms ] - [ vertex-array>> >>vertex-array ] bi - render ; + loading>> { + { "primitive-mode" [ drop triangle-strip-mode ] } + { "indexes" [ drop T{ index-range f 0 4 } ] } + { "uniforms" [ { 1.0 -1.0 } swap texture>> loading-uniforms boa ] } + { "vertex-array" [ vertex-array>> ] } + } render ; M: bunny-world draw-world* dup bunny>> diff --git a/extra/gpu/demos/raytrace/raytrace.factor b/extra/gpu/demos/raytrace/raytrace.factor index df323d3c82..9ac943150d 100644 --- a/extra/gpu/demos/raytrace/raytrace.factor +++ b/extra/gpu/demos/raytrace/raytrace.factor @@ -1,7 +1,7 @@ ! (c)2009 Joe Groff bsd license -USING: accessors arrays game-loop game-worlds generalizations -gpu gpu.render gpu.shaders gpu.util gpu.util.wasd kernel -literals math math.matrices math.order math.vectors +USING: accessors arrays combinators.tuple game-loop game-worlds +generalizations gpu gpu.render gpu.shaders gpu.util gpu.util.wasd +kernel literals math math.matrices math.order math.vectors method-chains sequences ui ui.gadgets ui.gadgets.worlds ui.pixel-formats ; IN: gpu.demos.raytrace @@ -97,13 +97,12 @@ AFTER: raytrace-world tick* spheres>> [ tick-sphere ] each ; M: raytrace-world draw-world* - render-set new - triangle-strip-mode >>primitive-mode - T{ index-range f 0 4 } >>indexes - swap - [ >>uniforms ] - [ vertex-array>> >>vertex-array ] bi - render ; + { + { "primitive-mode" [ drop triangle-strip-mode ] } + { "indexes" [ drop T{ index-range f 0 4 } ] } + { "uniforms" [ ] } + { "vertex-array" [ vertex-array>> ] } + } render ; M: raytrace-world pref-dim* drop { 1024 768 } ; M: raytrace-world tick-length drop 1000 30 /i ; diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index 65a99f94d7..feb2f3f768 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -1,7 +1,7 @@ ! (c)2009 Joe Groff bsd license USING: accessors alien alien.c-types alien.structs arrays assocs classes.mixin classes.parser classes.singleton -classes.tuple classes.tuple.private combinators destructors fry +classes.tuple classes.tuple.private combinators combinators.tuple destructors fry generic generic.parser gpu gpu.buffers gpu.framebuffers gpu.framebuffers.private gpu.shaders gpu.state gpu.textures gpu.textures.private half-floats images kernel lexer locals @@ -474,13 +474,22 @@ M: vertex-array dispose PRIVATE> TUPLE: render-set - { primitive-mode primitive-mode } - { vertex-array vertex-array } - { uniforms uniform-tuple } - { indexes vertex-indexes initial: T{ index-range } } - { instances ?integer initial: f } - { framebuffer any-framebuffer initial: system-framebuffer } - { output-attachments sequence initial: { default-attachment } } ; + { primitive-mode primitive-mode read-only } + { vertex-array vertex-array read-only } + { uniforms uniform-tuple read-only } + { indexes vertex-indexes initial: T{ index-range } read-only } + { instances ?integer initial: f read-only } + { framebuffer any-framebuffer initial: system-framebuffer read-only } + { output-attachments sequence initial: { default-attachment } read-only } ; + +: ( x quot-assoc -- render-set ) + render-set swap make-tuple ; inline + +: 2 ( x y quot-assoc -- render-set ) + render-set swap 2make-tuple ; inline + +: 3 ( x y z quot-assoc -- render-set ) + render-set swap 3make-tuple ; inline : render ( render-set -- ) { From d29c2750894e0d3fb9ae2bda01aa92199daa4b7f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 19:17:21 -0500 Subject: [PATCH 24/52] compiler.cfg.builder: Fix construction of ##return instructions from #return-recursive nodes --- basis/compiler/cfg/builder/builder-tests.factor | 10 ++++++++++ basis/compiler/cfg/builder/builder.factor | 9 +++++---- 2 files changed, 15 insertions(+), 4 deletions(-) diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 90e42912a1..7381bdca55 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -9,6 +9,15 @@ byte-arrays kernel.private math slots.private ; : unit-test-cfg ( quot -- ) '[ _ test-cfg [ compute-predecessors check-cfg ] each ] [ ] swap unit-test ; +: blahblah ( nodes -- ? ) + { fixnum } declare [ + dup 3 bitand 1 = [ drop t ] [ + dup 3 bitand 2 = [ + blahblah + ] [ drop f ] if + ] if + ] any? ; inline recursive + { [ ] [ dup ] @@ -52,6 +61,7 @@ byte-arrays kernel.private math slots.private ; [ "int" { "int" } "cdecl" [ ] alien-callback ] [ swap - + * ] [ swap slot ] + [ blahblah ] } [ unit-test-cfg ] each diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 48162156c8..7a7156d5c9 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -160,12 +160,13 @@ M: #shuffle emit-node [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ; ! #return -M: #return emit-node - drop ##branch begin-basic-block ##epilogue ##return ; +: emit-return ( -- ) + ##branch begin-basic-block ##epilogue ##return ; + +M: #return emit-node drop emit-return ; M: #return-recursive emit-node - label>> id>> loops get key? - [ ##epilogue ##return ] unless ; + label>> id>> loops get key? [ emit-return ] unless ; ! #terminate M: #terminate emit-node drop ##no-tco basic-block off ; From 5559d77d05da0c792c444aa0587912362108c658 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 19:17:57 -0500 Subject: [PATCH 25/52] compiler.cfg.checker: eliminate dead code before checking MR --- basis/compiler/cfg/checker/checker.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index f4738c675c..53f84b1dda 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities -compiler.cfg.mr combinators.short-circuit accessors math sequences -sets assocs ; +compiler.cfg.dce compiler.cfg.mr combinators.short-circuit accessors +math sequences sets assocs ; IN: compiler.cfg.checker ERROR: bad-kill-block bb ; @@ -64,5 +64,5 @@ ERROR: undefined-values uses defs ; : check-cfg ( cfg -- ) [ [ check-basic-block ] each-basic-block ] - [ build-mr check-mr ] + [ eliminate-dead-code build-mr check-mr ] bi ; From 45c66b58afb278b325ff63058d8cf749ed0affa5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 19:18:12 -0500 Subject: [PATCH 26/52] compiler.cfg.dcn.rewrite: remove unused word --- basis/compiler/cfg/dcn/rewrite/rewrite.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/basis/compiler/cfg/dcn/rewrite/rewrite.factor b/basis/compiler/cfg/dcn/rewrite/rewrite.factor index e91aa248e6..bbc6783f79 100644 --- a/basis/compiler/cfg/dcn/rewrite/rewrite.factor +++ b/basis/compiler/cfg/dcn/rewrite/rewrite.factor @@ -14,9 +14,6 @@ IN: compiler.cfg.dcn.rewrite peek-in swap [ peek-out ] [ avail-out ] bi assoc-union assoc-diff ; -: remove-dead-stores ( assoc -- assoc' ) - [ drop n>> 0 >= ] assoc-filter ; - : inserting-replaces ( from to -- assoc ) [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi* assoc-union assoc-diff ; From 69ded76c66df4c30e16351411f1adbf45489ae2d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 21:10:50 -0500 Subject: [PATCH 27/52] Fixing compiler tests --- basis/compiler/cfg/dcn/dcn-tests.factor | 4 ++-- basis/compiler/tests/codegen.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/dcn/dcn-tests.factor b/basis/compiler/cfg/dcn/dcn-tests.factor index 3dfaa665aa..c987d9edd2 100644 --- a/basis/compiler/cfg/dcn/dcn-tests.factor +++ b/basis/compiler/cfg/dcn/dcn-tests.factor @@ -24,7 +24,7 @@ compiler.cfg.dcn.rewrite ; [ inserting-peeks ] keep untranslate-locs keys ; : inserting-replaces' ( from to -- assoc ) - [ inserting-replaces ] keep untranslate-locs remove-dead-stores keys ; + [ inserting-replaces ] keep untranslate-locs [ drop n>> 0 >= ] assoc-filter keys ; [ V{ @@ -78,7 +78,7 @@ compiler.cfg.dcn.rewrite ; cfg new 0 get >>entry compute-predecessors deconcatenatize - check-cfg ; + drop ; V{ T{ ##epilogue } T{ ##return } } 0 test-bb diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 9f573019c2..4494df1705 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -286,7 +286,7 @@ M: cucumber equal? "The cucumber has no equal" throw ; [ 4294967295 B{ 255 255 255 255 } -1 ] [ -1 -1 - [ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ] + [ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ] compile-call ] unit-test From 610c3b33c75b927d393496f123b2455cd368361c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 21:11:06 -0500 Subject: [PATCH 28/52] compiler.cfg.intrinsics: Disable inline allocation for now --- basis/compiler/cfg/intrinsics/intrinsics.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 2618db0904..c6642d8ad9 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -48,11 +48,11 @@ IN: compiler.cfg.intrinsics slots.private:set-slot strings.private:string-nth strings.private:set-string-nth-fast - classes.tuple.private: - arrays: - byte-arrays: - byte-arrays:(byte-array) - kernel: + ! classes.tuple.private: + ! arrays: + ! byte-arrays: + ! byte-arrays:(byte-array) + ! kernel: alien.accessors:alien-unsigned-1 alien.accessors:set-alien-unsigned-1 alien.accessors:alien-signed-1 @@ -61,7 +61,7 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-unsigned-2 alien.accessors:alien-signed-2 alien.accessors:set-alien-signed-2 - alien.accessors:alien-cell + ! alien.accessors:alien-cell alien.accessors:set-alien-cell } [ t "intrinsic" set-word-prop ] each @@ -90,7 +90,7 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-float alien.accessors:alien-double alien.accessors:set-alien-double - } [ t "intrinsic" set-word-prop ] each ; + } drop f [ t "intrinsic" set-word-prop ] each ; : enable-fixnum-log2 ( -- ) \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ; From dd2bbc51b378a4ea88e12608b5656515dd57cc19 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 21:12:04 -0500 Subject: [PATCH 29/52] unix.types: define alias; use it in calendar.unix to avoid clobbering data --- basis/calendar/unix/unix.factor | 4 ++-- basis/unix/types/freebsd/freebsd.factor | 4 +++- basis/unix/types/linux/linux.factor | 4 +++- basis/unix/types/macosx/macosx.factor | 4 +++- basis/unix/types/netbsd/netbsd.factor | 4 +++- basis/unix/types/openbsd/openbsd.factor | 4 +++- 6 files changed, 17 insertions(+), 7 deletions(-) diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index 9848d0c164..aa4e8f7e9a 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax arrays calendar -kernel math unix unix.time namespaces system ; +kernel math unix unix.time unix.types namespaces system ; IN: calendar.unix : timeval>seconds ( timeval -- seconds ) @@ -19,7 +19,7 @@ IN: calendar.unix timespec>seconds since-1970 ; : get-time ( -- alien ) - f time localtime ; + f time localtime ; : timezone-name ( -- string ) get-time tm-zone ; diff --git a/basis/unix/types/freebsd/freebsd.factor b/basis/unix/types/freebsd/freebsd.factor index e012ebcbd6..215e344231 100644 --- a/basis/unix/types/freebsd/freebsd.factor +++ b/basis/unix/types/freebsd/freebsd.factor @@ -1,4 +1,4 @@ -USING: alien.syntax ; +USING: alien.syntax alien.c-types ; IN: unix.types @@ -22,3 +22,5 @@ TYPEDEF: __uint32_t fflags_t TYPEDEF: long ssize_t TYPEDEF: int pid_t TYPEDEF: int time_t + +ALIAS: diff --git a/basis/unix/types/linux/linux.factor b/basis/unix/types/linux/linux.factor index b0340c1778..a3dddfc93e 100644 --- a/basis/unix/types/linux/linux.factor +++ b/basis/unix/types/linux/linux.factor @@ -1,4 +1,4 @@ -USING: alien.syntax ; +USING: alien.syntax alien.c-types ; IN: unix.types TYPEDEF: ulonglong __uquad_type @@ -31,3 +31,5 @@ TYPEDEF: ulonglong __fsblkcnt64_t TYPEDEF: ulonglong __fsfilcnt64_t TYPEDEF: ulonglong ino64_t TYPEDEF: ulonglong off64_t + +ALIAS: \ No newline at end of file diff --git a/basis/unix/types/macosx/macosx.factor b/basis/unix/types/macosx/macosx.factor index ac62776ed7..421efa60bc 100644 --- a/basis/unix/types/macosx/macosx.factor +++ b/basis/unix/types/macosx/macosx.factor @@ -1,4 +1,4 @@ -USING: alien.syntax ; +USING: alien.syntax alien.c-types ; IN: unix.types ! Darwin 9.1.0 @@ -21,3 +21,5 @@ TYPEDEF: __int32_t blksize_t TYPEDEF: long ssize_t TYPEDEF: __int32_t pid_t TYPEDEF: long time_t + +ALIAS: \ No newline at end of file diff --git a/basis/unix/types/netbsd/netbsd.factor b/basis/unix/types/netbsd/netbsd.factor index b5b0ffe661..7dacc97061 100644 --- a/basis/unix/types/netbsd/netbsd.factor +++ b/basis/unix/types/netbsd/netbsd.factor @@ -1,4 +1,4 @@ -USING: alien.syntax combinators layouts vocabs.loader ; +USING: alien.syntax alien.c-types combinators layouts vocabs.loader ; IN: unix.types ! NetBSD 4.0 @@ -17,6 +17,8 @@ TYPEDEF: long ssize_t TYPEDEF: int pid_t TYPEDEF: int time_t +ALIAS: + cell-bits { { 32 [ "unix.types.netbsd.32" require ] } { 64 [ "unix.types.netbsd.64" require ] } diff --git a/basis/unix/types/openbsd/openbsd.factor b/basis/unix/types/openbsd/openbsd.factor index 8938afa936..7c8fbd2b9d 100644 --- a/basis/unix/types/openbsd/openbsd.factor +++ b/basis/unix/types/openbsd/openbsd.factor @@ -1,4 +1,4 @@ -USING: alien.syntax ; +USING: alien.syntax alien.c-types ; IN: unix.types ! OpenBSD 4.2 @@ -17,3 +17,5 @@ TYPEDEF: __uint32_t fflags_t TYPEDEF: long ssize_t TYPEDEF: int pid_t TYPEDEF: int time_t + +ALIAS: \ No newline at end of file From bba46d2b3091dc9574e017fd948ba145d2b04342 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 22 Jul 2009 22:32:02 -0500 Subject: [PATCH 30/52] improve uniform-tuple interface in gpu.render. uniform-tuples can now contain other uniform-tuples to represent struct uniforms. use glUniform*v to blast uniform arrays in one shot. s/-/_/ in slot names so they look more factorish on the CPU side --- extra/gpu/demos/bunny/bunny.factor | 24 +-- extra/gpu/demos/raytrace/raytrace.factor | 42 ++--- extra/gpu/render/render.factor | 218 +++++++++++++++++------ 3 files changed, 193 insertions(+), 91 deletions(-) diff --git a/extra/gpu/demos/bunny/bunny.factor b/extra/gpu/demos/bunny/bunny.factor index a1b42d9f12..f975b21245 100755 --- a/extra/gpu/demos/bunny/bunny.factor +++ b/extra/gpu/demos/bunny/bunny.factor @@ -53,22 +53,22 @@ VERTEX-FORMAT: bunny-vertex VERTEX-STRUCT: bunny-vertex-struct bunny-vertex UNIFORM-TUPLE: bunny-uniforms < mvp-uniforms - { "light_position" float-uniform 3 } - { "color" float-uniform 4 } - { "ambient" float-uniform 4 } - { "diffuse" float-uniform 4 } - { "shininess" float-uniform 1 } ; + { "light-position" vec3-uniform f } + { "color" vec4-uniform f } + { "ambient" vec4-uniform f } + { "diffuse" vec4-uniform f } + { "shininess" float-uniform f } ; UNIFORM-TUPLE: sobel-uniforms - { "texcoord_scale" float-uniform 2 } - { "color_texture" texture-uniform 1 } - { "normal_texture" texture-uniform 1 } - { "depth_texture" texture-uniform 1 } - { "line_color" float-uniform 4 } ; + { "texcoord-scale" vec2-uniform f } + { "color-texture" texture-uniform f } + { "normal-texture" texture-uniform f } + { "depth-texture" texture-uniform f } + { "line-color" vec4-uniform f } ; UNIFORM-TUPLE: loading-uniforms - { "texcoord_scale" float-uniform 2 } - { "loading_texture" texture-uniform 1 } ; + { "texcoord-scale" vec2-uniform f } + { "loading-texture" texture-uniform f } ; : numbers ( str -- seq ) " " split [ string>number ] map sift ; diff --git a/extra/gpu/demos/raytrace/raytrace.factor b/extra/gpu/demos/raytrace/raytrace.factor index 9ac943150d..339f192416 100644 --- a/extra/gpu/demos/raytrace/raytrace.factor +++ b/extra/gpu/demos/raytrace/raytrace.factor @@ -11,31 +11,21 @@ GLSL-SHADER-FILE: raytrace-fragment-shader fragment-shader "raytrace.f.glsl" GLSL-PROGRAM: raytrace-program raytrace-vertex-shader raytrace-fragment-shader ; +UNIFORM-TUPLE: sphere-uniforms + { "center" vec3-uniform f } + { "radius" float-uniform f } + { "color" vec4-uniform f } ; + UNIFORM-TUPLE: raytrace-uniforms - { "mv_inv_matrix" float-uniform { 4 4 } } - { "fov" float-uniform 2 } - - { "spheres[0].center" float-uniform 3 } - { "spheres[0].radius" float-uniform 1 } - { "spheres[0].color" float-uniform 4 } - - { "spheres[1].center" float-uniform 3 } - { "spheres[1].radius" float-uniform 1 } - { "spheres[1].color" float-uniform 4 } - - { "spheres[2].center" float-uniform 3 } - { "spheres[2].radius" float-uniform 1 } - { "spheres[2].color" float-uniform 4 } - - { "spheres[3].center" float-uniform 3 } - { "spheres[3].radius" float-uniform 1 } - { "spheres[3].color" float-uniform 4 } + { "mv-inv-matrix" mat4-uniform f } + { "fov" vec2-uniform f } - { "floor_height" float-uniform 1 } - { "floor_color[0]" float-uniform 4 } - { "floor_color[1]" float-uniform 4 } - { "background_color" float-uniform 4 } - { "light_direction" float-uniform 3 } ; + { "spheres" sphere-uniforms 4 } + + { "floor-height" float-uniform f } + { "floor-color" vec4-uniform 2 } + { "background-color" vec4-uniform f } + { "light-direction" vec3-uniform f } ; CONSTANT: reflection-color { 1.0 0.0 1.0 0.0 } @@ -64,12 +54,10 @@ TUPLE: raytrace-world < wasd-world [ fov>> ] [ spheres>> - [ [ sphere-center ] [ radius>> ] [ color>> ] tri 3array ] map - first4 [ first3 ] 4 napply + [ [ sphere-center ] [ radius>> ] [ color>> ] tri sphere-uniforms boa ] map ] tri -30.0 ! floor_height - { 1.0 0.0 0.0 1.0 } ! floor_color[0] - { 1.0 1.0 1.0 1.0 } ! floor_color[1] + { { 1.0 0.0 0.0 1.0 } { 1.0 1.0 1.0 1.0 } } ! floor_color { 0.15 0.15 1.0 1.0 } ! background_color { 0.0 -1.0 -0.1 } ! light_direction raytrace-uniforms boa ; diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index feb2f3f768..a0457e8082 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -1,6 +1,6 @@ ! (c)2009 Joe Groff bsd license USING: accessors alien alien.c-types alien.structs arrays -assocs classes.mixin classes.parser classes.singleton +assocs classes classes.mixin classes.parser classes.singleton classes.tuple classes.tuple.private combinators combinators.tuple destructors fry generic generic.parser gpu gpu.buffers gpu.framebuffers gpu.framebuffers.private gpu.shaders gpu.state gpu.textures @@ -8,12 +8,12 @@ gpu.textures.private half-floats images kernel lexer locals math math.order math.parser namespaces opengl opengl.gl parser quotations sequences slots sorting specialized-arrays.alien specialized-arrays.float specialized-arrays.int -specialized-arrays.uint strings ui.gadgets.worlds variants +specialized-arrays.uint strings tr ui.gadgets.worlds variants vocabs.parser words ; IN: gpu.render UNION: ?string string POSTPONE: f ; -UNION: uniform-dim integer sequence ; +UNION: ?integer integer POSTPONE: f ; TUPLE: vertex-attribute { name ?string read-only initial: f } @@ -23,15 +23,44 @@ TUPLE: vertex-attribute VARIANT: uniform-type bool-uniform + bvec2-uniform + bvec3-uniform + bvec4-uniform uint-uniform + uvec2-uniform + uvec3-uniform + uvec4-uniform int-uniform + ivec2-uniform + ivec3-uniform + ivec4-uniform float-uniform + vec2-uniform + vec3-uniform + vec4-uniform + + mat2-uniform + mat2x3-uniform + mat2x4-uniform + + mat3x2-uniform + mat3-uniform + mat3x4-uniform + + mat4x2-uniform + mat4x3-uniform + mat4-uniform + texture-uniform ; +ALIAS: mat2x2-uniform mat2-uniform +ALIAS: mat3x3-uniform mat3-uniform +ALIAS: mat4x4-uniform mat4-uniform + TUPLE: uniform - { name string read-only initial: "" } - { uniform-type uniform-type read-only initial: float-uniform } - { dim uniform-dim read-only initial: 4 } ; + { name string read-only initial: "" } + { uniform-type class read-only initial: float-uniform } + { dim ?integer read-only initial: f } ; VARIANT: index-type ubyte-indexes @@ -50,8 +79,6 @@ TUPLE: multi-index-range C: multi-index-range -UNION: ?integer integer POSTPONE: f ; - TUPLE: index-elements { ptr gpu-data-ptr read-only } { count integer read-only } @@ -242,19 +269,23 @@ M: uniform-tuple bind-uniforms 2drop ; : uniform-slot-type ( uniform -- type ) - dup dim>> 1 = [ + dup dim>> [ drop sequence ] [ uniform-type>> { { bool-uniform [ boolean ] } { uint-uniform [ integer ] } { int-uniform [ integer ] } { float-uniform [ float ] } { texture-uniform [ texture ] } + [ drop sequence ] } case - ] [ drop sequence ] if ; + ] if ; : uniform>slot ( uniform -- slot ) [ name>> ] [ uniform-slot-type ] bi 2array ; +: uniform-type-texture-units ( uniform-type -- units ) + dup texture-uniform = [ drop 1 ] [ "uniform-tuple-texture-units" word-prop 0 or ] if ; + :: [bind-uniform-texture] ( uniform index -- quot ) uniform name>> reader-word :> value>>-word { index swap value>>-word (bind-texture-unit) } >quotation ; @@ -272,61 +303,144 @@ M: uniform-tuple bind-uniforms nip texture-uniforms-cleave cleave } >quotation ; -:: [bind-uniform] ( texture-unit uniform -- texture-unit' quot ) - uniform name>> :> name +DEFER: [bind-uniform-tuple] + +:: [bind-uniform-array] ( value>>-quot type texture-unit name dim -- texture-unit' quot ) { name uniform-index } >quotation :> index-quot - uniform name>> reader-word 1quotation :> value>>-quot { index-quot value>>-quot bi* } >quotation :> pre-quot - uniform [ uniform-type>> ] [ dim>> ] bi 2array H{ - { { bool-uniform 1 } [ >c-bool glUniform1i ] } - { { int-uniform 1 } [ glUniform1i ] } - { { uint-uniform 1 } [ glUniform1ui ] } - { { float-uniform 1 } [ glUniform1f ] } + type H{ + { bool-uniform { dim swap [ >c-bool ] int-array{ } map-as glUniform1iv } } + { int-uniform { dim swap >int-array glUniform1iv } } + { uint-uniform { dim swap >uint-array glUniform1uiv } } + { float-uniform { dim swap >float-array glUniform1fv } } - { { bool-uniform 2 } [ [ >c-bool ] map first2 glUniform2i ] } - { { int-uniform 2 } [ first2 glUniform2i ] } - { { uint-uniform 2 } [ first2 glUniform2ui ] } - { { float-uniform 2 } [ first2 glUniform2f ] } + { bvec2-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform2iv } } + { ivec2-uniform { dim swap int-array{ } concat-as glUniform2i } } + { uvec2-uniform { dim swap uint-array{ } concat-as glUniform2ui } } + { vec2-uniform { dim swap float-array{ } concat-as glUniform2f } } - { { bool-uniform 3 } [ [ >c-bool ] map first3 glUniform3i ] } - { { int-uniform 3 } [ first3 glUniform3i ] } - { { uint-uniform 3 } [ first3 glUniform3ui ] } - { { float-uniform 3 } [ first3 glUniform3f ] } + { bvec3-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform3iv } } + { ivec3-uniform { dim swap int-array{ } concat-as glUniform3i } } + { uvec3-uniform { dim swap uint-array{ } concat-as glUniform3ui } } + { vec3-uniform { dim swap float-array{ } concat-as glUniform3f } } - { { bool-uniform 4 } [ [ >c-bool ] map first4 glUniform4i ] } - { { int-uniform 4 } [ first4 glUniform4i ] } - { { uint-uniform 4 } [ first4 glUniform4ui ] } - { { float-uniform 4 } [ first4 glUniform4f ] } + { bvec4-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform4iv } } + { ivec4-uniform { dim swap int-array{ } concat-as glUniform4iv } } + { uvec4-uniform { dim swap uint-array{ } concat-as glUniform4uiv } } + { vec4-uniform { dim swap float-array{ } concat-as glUniform4fv } } - { { float-uniform { 2 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2fv ] } - { { float-uniform { 3 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x3fv ] } - { { float-uniform { 4 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x4fv ] } + { mat2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2fv } } + { mat2x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x3fv } } + { mat2x4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x4fv } } + + { mat3x2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3x2fv } } + { mat3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3fv } } + { mat3x4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3x4fv } } + + { mat4x2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x2fv } } + { mat4x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x3fv } } + { mat4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4fv } } - { { float-uniform { 2 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3x2fv ] } - { { float-uniform { 3 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3fv ] } - { { float-uniform { 4 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3x4fv ] } - - { { float-uniform { 2 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4x2fv ] } - { { float-uniform { 3 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4x3fv ] } - { { float-uniform { 4 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4fv ] } - - { { texture-uniform 1 } { drop texture-unit glUniform1i } } + { texture-uniform { drop dim iota [ texture-unit + ] int-array{ } map-as glUniform1iv } } } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot - uniform uniform-type>> texture-uniform = - [ texture-unit 1 + ] [ texture-unit ] if + type uniform-type-texture-units dim * texture-unit + pre-quot value-quot append ; +:: [bind-uniform-value] ( value>>-quot type texture-unit name -- texture-unit' quot ) + { name uniform-index } >quotation :> index-quot + { index-quot value>>-quot bi* } >quotation :> pre-quot + + type H{ + { bool-uniform [ >c-bool glUniform1i ] } + { int-uniform [ glUniform1i ] } + { uint-uniform [ glUniform1ui ] } + { float-uniform [ glUniform1f ] } + + { bvec2-uniform [ [ >c-bool ] map first2 glUniform2i ] } + { ivec2-uniform [ first2 glUniform2i ] } + { uvec2-uniform [ first2 glUniform2ui ] } + { vec2-uniform [ first2 glUniform2f ] } + + { bvec3-uniform [ [ >c-bool ] map first3 glUniform3i ] } + { ivec3-uniform [ first3 glUniform3i ] } + { uvec3-uniform [ first3 glUniform3ui ] } + { vec3-uniform [ first3 glUniform3f ] } + + { bvec4-uniform [ [ >c-bool ] map first4 glUniform4i ] } + { ivec4-uniform [ first4 glUniform4i ] } + { uvec4-uniform [ first4 glUniform4ui ] } + { vec4-uniform [ first4 glUniform4f ] } + + { mat2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2fv ] } + { mat2x3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2x3fv ] } + { mat2x4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2x4fv ] } + + { mat3x2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3x2fv ] } + { mat3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3fv ] } + { mat3x4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3x4fv ] } + + { mat4x2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4x2fv ] } + { mat4x3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4x3fv ] } + { mat4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4fv ] } + + { texture-uniform { drop texture-unit glUniform1i } } + } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot + + type uniform-type-texture-units texture-unit + + pre-quot value-quot append ; + +: all-uniform-tuple-slots ( class -- slots ) + dup "uniform-tuple-slots" word-prop + [ swap superclass all-uniform-tuple-slots append ] [ drop { } ] if* ; + +:: [bind-uniform-struct] ( value>>-quot type texture-unit name dim -- texture-unit' quot ) + dim + [ + iota + [ [ [ swap nth ] swap prefix ] map ] + [ [ number>string name "[" append "]." surround ] map ] bi + ] [ + { [ ] } + name "." append 1array + ] if* :> name-prefixes :> quot-prefixes + type all-uniform-tuple-slots :> uniforms + + texture-unit quot-prefixes name-prefixes [| quot-prefix name-prefix | + uniforms name-prefix [bind-uniform-tuple] + quot-prefix prepend + ] 2map :> value-cleave :> texture-unit' + + texture-unit' + value>>-quot { value-cleave 2cleave } append ; + +TR: hyphens>underscores "-" "_" ; + +:: [bind-uniform] ( texture-unit uniform prefix -- texture-unit' quot ) + prefix uniform name>> append hyphens>underscores :> name + uniform uniform-type>> :> type + uniform dim>> :> dim + uniform name>> reader-word 1quotation :> value>>-quot + + value>>-quot type texture-unit name { + { [ type uniform-type? dim and ] [ dim [bind-uniform-array] ] } + { [ type uniform-type? dim not and ] [ [bind-uniform-value] ] } + [ dim [bind-uniform-struct] ] + } cond ; + +:: [bind-uniform-tuple] ( texture-unit uniforms prefix -- texture-unit' quot ) + texture-unit uniforms [ prefix [bind-uniform] ] map :> uniforms-cleave :> texture-unit' + + texture-unit' + { uniforms-cleave 2cleave } >quotation ; + :: [bind-uniforms] ( superclass uniforms -- quot ) superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit superclass \ bind-uniforms method :> next-method - first-texture-unit uniforms [ [bind-uniform] ] map nip :> uniforms-cleave - - { - 2dup next-method - uniforms-cleave 2cleave - } >quotation ; + first-texture-unit uniforms "" [bind-uniform-tuple] nip :> bind-quot + + { 2dup next-method } bind-quot [ ] append-as ; : define-uniform-tuple-methods ( class superclass uniforms -- ) [ @@ -386,8 +500,8 @@ padding-no [ 0 ] initialize [ [ uniform>slot ] map define-tuple-class ] [ define-uniform-tuple-methods ] [ - [ "uniform-tuple-texture-units" word-prop 0 or ] - [ [ uniform-type>> texture-uniform = ] filter length ] bi* + + [ uniform-type-texture-units ] + [ [ uniform-type>> uniform-type-texture-units ] [ + ] map-reduce ] bi* + "uniform-tuple-texture-units" set-word-prop ] [ nip "uniform-tuple-slots" set-word-prop ] From 2a194ea78000d6a3e885e87bd748dab70caaa27c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 23 Jul 2009 13:01:21 -0500 Subject: [PATCH 31/52] bind textures out of uniform structs and arrays --- extra/gpu/render/render-tests.factor | 117 +++++++++++++++++++++++++++ extra/gpu/render/render.factor | 81 ++++++++++++------- 2 files changed, 167 insertions(+), 31 deletions(-) create mode 100644 extra/gpu/render/render-tests.factor diff --git a/extra/gpu/render/render-tests.factor b/extra/gpu/render/render-tests.factor new file mode 100644 index 0000000000..90a8dcc2cb --- /dev/null +++ b/extra/gpu/render/render-tests.factor @@ -0,0 +1,117 @@ +USING: accessors combinators gpu.render gpu.render.private kernel sequences tools.test ; +IN: gpu.render.tests + +UNIFORM-TUPLE: two-textures + { "argyle" texture-uniform f } + { "thread-count" float-uniform f } + { "tweed" texture-uniform f } ; + +UNIFORM-TUPLE: inherited-textures < two-textures + { "paisley" texture-uniform f } ; + +UNIFORM-TUPLE: array-of-textures < two-textures + { "plaids" texture-uniform 4 } ; + +UNIFORM-TUPLE: struct-containing-texture + { "threads" two-textures f } ; + +UNIFORM-TUPLE: array-of-struct-containing-texture + { "threads" inherited-textures 3 } ; + +UNIFORM-TUPLE: array-of-struct-containing-array-of-texture + { "threads" array-of-textures 2 } ; + +[ 1 ] [ texture-uniform uniform-type-texture-units ] unit-test +[ 0 ] [ float-uniform uniform-type-texture-units ] unit-test +[ 2 ] [ two-textures uniform-type-texture-units ] unit-test +[ 3 ] [ inherited-textures uniform-type-texture-units ] unit-test +[ 6 ] [ array-of-textures uniform-type-texture-units ] unit-test +[ 2 ] [ struct-containing-texture uniform-type-texture-units ] unit-test +[ 9 ] [ array-of-struct-containing-texture uniform-type-texture-units ] unit-test +[ 12 ] [ array-of-struct-containing-array-of-texture uniform-type-texture-units ] unit-test + +[ { [ ] } ] [ texture-uniform f uniform-texture-accessors ] unit-test + +[ { } ] [ float-uniform f uniform-texture-accessors ] unit-test + +[ { [ argyle>> ] [ tweed>> ] } ] [ two-textures f uniform-texture-accessors ] unit-test + +[ { [ argyle>> ] [ tweed>> ] [ paisley>> ] } ] +[ inherited-textures f uniform-texture-accessors ] unit-test + +[ { + [ argyle>> ] + [ tweed>> ] + [ plaids>> { + [ 0 swap nth ] + [ 1 swap nth ] + [ 2 swap nth ] + [ 3 swap nth ] + } ] +} ] [ array-of-textures f uniform-texture-accessors ] unit-test + +[ { + [ threads>> { + [ argyle>> ] + [ tweed>> ] + } ] +} ] [ struct-containing-texture f uniform-texture-accessors ] unit-test + +[ { + [ threads>> { + [ 0 swap nth { + [ argyle>> ] + [ tweed>> ] + [ paisley>> ] + } ] + [ 1 swap nth { + [ argyle>> ] + [ tweed>> ] + [ paisley>> ] + } ] + [ 2 swap nth { + [ argyle>> ] + [ tweed>> ] + [ paisley>> ] + } ] + } ] +} ] [ array-of-struct-containing-texture f uniform-texture-accessors ] unit-test + +[ { + [ threads>> { + [ 0 swap nth { + [ argyle>> ] + [ tweed>> ] + [ plaids>> { + [ 0 swap nth ] + [ 1 swap nth ] + [ 2 swap nth ] + [ 3 swap nth ] + } ] + } ] + [ 1 swap nth { + [ argyle>> ] + [ tweed>> ] + [ plaids>> { + [ 0 swap nth ] + [ 1 swap nth ] + [ 2 swap nth ] + [ 3 swap nth ] + } ] + } ] + } ] +} ] [ array-of-struct-containing-array-of-texture f uniform-texture-accessors ] unit-test + +[ [ + nip { + [ argyle>> 0 (bind-texture-unit) ] + [ tweed>> 1 (bind-texture-unit) ] + [ plaids>> { + [ 0 swap nth 2 (bind-texture-unit) ] + [ 1 swap nth 3 (bind-texture-unit) ] + [ 2 swap nth 4 (bind-texture-unit) ] + [ 3 swap nth 5 (bind-texture-unit) ] + } cleave ] + } cleave +] ] [ array-of-textures [bind-uniform-textures] ] unit-test + diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index a0457e8082..51bd549b7a 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -207,8 +207,8 @@ M: multi-index-elements render-vertex-indexes bi* GL_ELEMENT_ARRAY_BUFFER swap [ handle>> ] [ 0 ] if* glBindBuffer glMultiDrawElements ; -: (bind-texture-unit) ( texture-unit texture -- ) - [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline +: (bind-texture-unit) ( texture texture-unit -- ) + swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot ) vertex-attribute name>> :> name @@ -286,22 +286,46 @@ M: uniform-tuple bind-uniforms : uniform-type-texture-units ( uniform-type -- units ) dup texture-uniform = [ drop 1 ] [ "uniform-tuple-texture-units" word-prop 0 or ] if ; -:: [bind-uniform-texture] ( uniform index -- quot ) - uniform name>> reader-word :> value>>-word - { index swap value>>-word (bind-texture-unit) } >quotation ; +: all-uniform-tuple-slots ( class -- slots ) + dup "uniform-tuple-slots" word-prop + [ swap superclass all-uniform-tuple-slots prepend ] [ drop { } ] if* ; -:: [bind-uniform-textures] ( superclass uniforms -- quot ) - superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit - superclass \ bind-uniform-textures method :> next-method - uniforms - [ uniform-type>> texture-uniform = ] filter - [ first-texture-unit + [bind-uniform-texture] ] map-index - :> texture-uniforms-cleave +DEFER: uniform-texture-accessors - { - 2dup next-method - nip texture-uniforms-cleave cleave - } >quotation ; +: uniform-type-texture-accessors ( uniform-type -- accessors ) + texture-uniform = [ { [ ] } ] [ { } ] if ; + +: uniform-slot-texture-accessor ( uniform -- accessor ) + [ name>> reader-word ] [ [ uniform-type>> ] [ dim>> ] bi uniform-texture-accessors ] bi + dup length 1 = [ first swap prefix ] [ [ ] 2sequence ] if ; + +: uniform-tuple-texture-accessors ( uniform-type -- accessors ) + all-uniform-tuple-slots [ uniform-type>> uniform-type-texture-units zero? not ] filter + [ uniform-slot-texture-accessor ] map ; + +: uniform-texture-accessors ( uniform-type dim -- accessors ) + [ + dup uniform-type? + [ uniform-type-texture-accessors ] + [ uniform-tuple-texture-accessors ] if + ] [ + 2dup swap empty? not and [ + iota [ + [ swap nth ] swap prefix + over length 1 = [ swap first append ] [ swap suffix ] if + ] with map + ] [ drop ] if + ] bi* ; + +: texture-accessor>cleave ( unit accessors -- unit' cleaves ) + dup last sequence? + [ [ last [ texture-accessor>cleave ] map ] [ but-last ] bi swap suffix \ cleave suffix ] + [ over suffix \ (bind-texture-unit) suffix [ 1 + ] dip ] if ; + +: [bind-uniform-textures] ( class -- quot ) + f uniform-texture-accessors + 0 swap [ texture-accessor>cleave ] map nip + \ nip swap \ cleave [ ] 3sequence ; DEFER: [bind-uniform-tuple] @@ -342,7 +366,7 @@ DEFER: [bind-uniform-tuple] { mat4x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x3fv } } { mat4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4fv } } - { texture-uniform { drop dim iota [ texture-unit + ] int-array{ } map-as glUniform1iv } } + { texture-uniform { drop dim dup iota [ texture-unit + ] int-array{ } map-as glUniform1iv } } } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot type uniform-type-texture-units dim * texture-unit + @@ -391,10 +415,6 @@ DEFER: [bind-uniform-tuple] type uniform-type-texture-units texture-unit + pre-quot value-quot append ; -: all-uniform-tuple-slots ( class -- slots ) - dup "uniform-tuple-slots" word-prop - [ swap superclass all-uniform-tuple-slots append ] [ drop { } ] if* ; - :: [bind-uniform-struct] ( value>>-quot type texture-unit name dim -- texture-unit' quot ) dim [ @@ -444,8 +464,9 @@ TR: hyphens>underscores "-" "_" ; : define-uniform-tuple-methods ( class superclass uniforms -- ) [ - [ \ bind-uniform-textures create-method-in ] 2dip - [bind-uniform-textures] define + 2drop + [ \ bind-uniform-textures create-method-in ] + [ [bind-uniform-textures] ] bi define ] [ [ \ bind-uniforms create-method-in ] 2dip [bind-uniforms] define @@ -498,22 +519,21 @@ padding-no [ 0 ] initialize : (define-uniform-tuple) ( class superclass uniforms -- ) { [ [ uniform>slot ] map define-tuple-class ] - [ define-uniform-tuple-methods ] [ [ uniform-type-texture-units ] - [ [ uniform-type>> uniform-type-texture-units ] [ + ] map-reduce ] bi* + + [ + [ [ uniform-type>> uniform-type-texture-units ] [ dim>> 1 or ] bi * ] + [ + ] map-reduce + ] bi* + "uniform-tuple-texture-units" set-word-prop ] [ nip "uniform-tuple-slots" set-word-prop ] + [ define-uniform-tuple-methods ] } 3cleave ; : true-subclasses ( class -- seq ) [ subclasses ] keep [ = not ] curry filter ; -: redefine-uniform-tuple-subclass-methods ( class -- ) - [ true-subclasses ] keep - [ over "uniform-tuple-slots" word-prop (define-uniform-tuple) ] curry each ; - PRIVATE> : define-vertex-format ( class vertex-attributes -- ) @@ -540,8 +560,7 @@ SYNTAX: VERTEX-STRUCT: scan scan-word define-vertex-struct ; : define-uniform-tuple ( class superclass uniforms -- ) - [ (define-uniform-tuple) ] - [ 2drop redefine-uniform-tuple-subclass-methods ] 3bi ; + (define-uniform-tuple) ; inline SYNTAX: UNIFORM-TUPLE: parse-uniform-tuple-definition define-uniform-tuple ; From 733c208f8c7c68872786f0148fc693e6970e8314 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 23 Jul 2009 13:39:28 -0500 Subject: [PATCH 32/52] doc updates for uniform-tuple changes --- extra/gpu/render/render-docs.factor | 99 +++++++++++++++++++++++++---- 1 file changed, 88 insertions(+), 11 deletions(-) diff --git a/extra/gpu/render/render-docs.factor b/extra/gpu/render/render-docs.factor index 68afc68f9b..8e761be13c 100755 --- a/extra/gpu/render/render-docs.factor +++ b/extra/gpu/render/render-docs.factor @@ -47,7 +47,7 @@ HELP: UNIFORM-TUPLE: { "slot" uniform-type dimension } ... { "slot" uniform-type dimension } ; "> } -{ $description "Defines a new " { $link uniform-tuple } " class. Tuples of the new class can be used as the " { $snippet "uniforms" } " slot of a " { $link render-set } " in order to set the uniform parameters of the active shader program. The " { $link uniform-type } " of each slot defines the component type, and the " { $snippet "dimension" } " defines the vector or matrix dimensions; for example, a slot " { $snippet "{ \"foo\" float-uniform { 2 2 } }" } " will define a slot " { $snippet "foo" } " as a 2x2 matrix of floats." +{ $description "Defines a new " { $link uniform-tuple } " class. Tuples of the new class can be used as the " { $snippet "uniforms" } " slot of a " { $link render-set } " in order to set the uniform parameters of the active shader program. The " { $link uniform-type } " of each slot defines the component type, and the " { $snippet "dimension" } " specifies an array length if not " { $link f } "." $nl "Uniform parameters are passed from Factor to the shader program through the uniform tuple as follows:" { $list @@ -55,8 +55,26 @@ $nl { { $link float-uniform } "s take their values from Factor " { $link float } "s." } { { $link bool-uniform } "s take their values from Factor " { $link boolean } "s." } { { $link texture-uniform } "s take their values from " { $link texture } " objects." } -{ "Vector uniforms are passed as Factor " { $link sequence } "s of the corresponding component type." } -{ "Matrix uniforms are passed as row-major Factor " { $link sequence } "s of sequences of the corresponding component type." } } +{ "Vector uniforms take their values from Factor " { $link sequence } "s of the corresponding component type." + { $list + { "Float vector types: " { $link vec2-uniform } ", " { $link vec3-uniform } ", " { $link vec4-uniform } } + { "Integer vector types: " { $link ivec2-uniform } ", " { $link ivec3-uniform } ", " { $link ivec4-uniform } } + { "Unsigned integer vector types: " { $link uvec2-uniform } ", " { $link uvec3-uniform } ", " { $link uvec4-uniform } } + { "Boolean vector types: " { $link bvec2-uniform } ", " { $link bvec3-uniform } ", " { $link bvec4-uniform } } + } +} +{ "Matrix uniforms take their values from row-major Factor " { $link sequence } "s of sequences of floats. Matrix types are:" + { $list + { { $link mat2-uniform } ", " { $link mat2x3-uniform } ", " { $link mat2x4-uniform } } + { { $link mat3x2-uniform } ", " { $link mat3-uniform } ", " { $link mat3x4-uniform } } + { { $link mat4x2-uniform } ", " { $link mat4x3-uniform } ", " { $link mat4-uniform } } + } +"Rectangular matrix type names are column x row." +} +{ "Uniform slots can also be defined as other " { $snippet "uniform-tuple" } " types to bind uniform structures. The uniform structure will take its value from the slots of a tuple of the given type." } +{ "Array uniforms are passed as Factor sequences of the corresponding value types above." } +} +$nl "A value of a uniform tuple type is a standard Factor tuple. Uniform tuples are constructed with " { $link new } " or " { $link boa } ", and values are placed inside them using standard slot accessors." } ; @@ -73,7 +91,7 @@ HELP: VERTEX-STRUCT: { $description "Defines a struct C type (like " { $link POSTPONE: C-STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ; HELP: bool-uniform -{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "bool" } "s." } ; +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a boolean uniform parameter." } ; HELP: buffer>vertex-array { $values @@ -84,6 +102,15 @@ HELP: buffer>vertex-array { vertex-array buffer>vertex-array } related-words +HELP: bvec2-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component boolean vector uniform parameter." } ; + +HELP: bvec3-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component boolean vector uniform parameter." } ; + +HELP: bvec4-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component boolean vector uniform parameter." } ; + HELP: define-uniform-tuple { $values { "class" class } { "superclass" class } { "uniforms" sequence } @@ -105,8 +132,6 @@ HELP: define-vertex-struct HELP: float-uniform { $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "float" } "s." } ; -{ bool-uniform int-uniform float-uniform texture-uniform } related-words - { index-elements index-range multi-index-elements multi-index-range } related-words HELP: index-elements @@ -130,7 +155,7 @@ HELP: index-type { index-type ubyte-indexes ushort-indexes uint-indexes } related-words HELP: int-uniform -{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "int" } "s." } ; +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a signed integer uniform parameter." } ; HELP: invalid-uniform-type { $values @@ -138,6 +163,15 @@ HELP: invalid-uniform-type } { $description "Throws an error indicating that a slot of a " { $link uniform-tuple } " has been declared to have an invalid type." } ; +HELP: ivec2-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component integer vector uniform parameter." } ; + +HELP: ivec3-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component integer vector uniform parameter." } ; + +HELP: ivec4-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component integer vector uniform parameter." } ; + HELP: lines-mode { $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a line from each pair of indexed vertex array elements." } ; @@ -147,6 +181,33 @@ HELP: line-loop-mode HELP: line-strip-mode { $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a connected strip of lines from each consecutive pair of indexed vertex array elements." } ; +HELP: mat2-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2x2 square float matrix uniform parameter." } ; + +HELP: mat2x3-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2-column, 3-row float matrix uniform parameter." } ; + +HELP: mat2x4-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2-column, 4-row float matrix uniform parameter." } ; + +HELP: mat3x2-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3-column, 2-row float matrix uniform parameter." } ; + +HELP: mat3-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3x3 square float matrix uniform parameter." } ; + +HELP: mat3x4-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3-column, 4-row float matrix uniform parameter." } ; + +HELP: mat4x2-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4-column, 2-row float matrix uniform parameter." } ; + +HELP: mat4x3-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4-column, 3-row float matrix uniform parameter." } ; + +HELP: mat4-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4x4 square float matrix uniform parameter." } ; + HELP: multi-index-elements { $class-description "Objects of this tuple class can be passed as the " { $snippet "indexes" } " slot of a non-instanced " { $link render-set } " to instruct " { $link render } " to assemble primitives from the active " { $link vertex-array } " by using multiple arrays of indexes in CPU or GPU memory." { $list @@ -200,7 +261,7 @@ HELP: render-set { render render-set } related-words HELP: texture-uniform -{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " is a texture. The dimension of the corresponding " { $link uniform } " slot must be " { $snippet "1" } "." } ; +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a texture uniform parameter." } ; HELP: triangle-fan-mode { $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to generate a fan of triangles using the first indexed vertex array element and every subsequent consecutive pair of elements." } ; @@ -218,7 +279,7 @@ HELP: uint-indexes { $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of four-byte unsigned int indexes." } ; HELP: uint-uniform -{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " is a scalar or vector of unsigned integers." } ; +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to an unsigned integer uniform parameter." } ; HELP: uniform { $class-description "Values of this tuple type are passed to " { $link define-uniform-tuple } " to define a new " { $link uniform-tuple } " type." } ; @@ -229,13 +290,29 @@ HELP: uniform-tuple HELP: uniform-type { $class-description { $snippet "uniform-type" } " values are used as part of a " { $link POSTPONE: UNIFORM-TUPLE: } " definition to define the types of uniform slots." } ; -{ uniform-type bool-uniform int-uniform float-uniform texture-uniform uint-uniform } related-words - HELP: ushort-indexes { $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of two-byte unsigned short indexes." } ; { index-type ubyte-indexes ushort-indexes uint-indexes } related-words +HELP: uvec2-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component unsigned integer vector uniform parameter." } ; + +HELP: uvec3-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component unsigned integer vector uniform parameter." } ; + +HELP: uvec4-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component unsigned integer vector uniform parameter." } ; + +HELP: vec2-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component float vector uniform parameter." } ; + +HELP: vec3-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component float vector uniform parameter." } ; + +HELP: vec4-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component float vector uniform parameter." } ; + HELP: vertex-array { $class-description "A " { $snippet "vertex-array" } " object associates a shader " { $link program-instance } " with vertex attribute data from one or more " { $link buffer } "s. The format of the binary data inside these buffers is described using " { $link vertex-format } "s. " { $snippet "vertex-array" } "s are constructed using the " { $link } " or " { $link buffer>vertex-array } " words." } ; From 3759cd7efcbd9594532c80d371e6f3a08e44c85e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 23 Jul 2009 14:58:45 -0500 Subject: [PATCH 33/52] update gpu.util.wasd to match uniform tuple changes --- extra/gpu/render/render-docs.factor | 4 ++-- extra/gpu/util/wasd/wasd.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/gpu/render/render-docs.factor b/extra/gpu/render/render-docs.factor index 8e761be13c..f198558b06 100755 --- a/extra/gpu/render/render-docs.factor +++ b/extra/gpu/render/render-docs.factor @@ -72,7 +72,7 @@ $nl "Rectangular matrix type names are column x row." } { "Uniform slots can also be defined as other " { $snippet "uniform-tuple" } " types to bind uniform structures. The uniform structure will take its value from the slots of a tuple of the given type." } -{ "Array uniforms are passed as Factor sequences of the corresponding value types above." } +{ "Array uniforms are passed as Factor sequences of the corresponding value type above." } } $nl "A value of a uniform tuple type is a standard Factor tuple. Uniform tuples are constructed with " { $link new } " or " { $link boa } ", and values are placed inside them using standard slot accessors." @@ -130,7 +130,7 @@ HELP: define-vertex-struct { $description "Defines a new struct C type from a " { $link vertex-format } ". The runtime equivalent of " { $link POSTPONE: VERTEX-STRUCT: } ". This word must be called inside a compilation unit." } ; HELP: float-uniform -{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "float" } "s." } ; +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a float uniform parameter." } ; { index-elements index-range multi-index-elements multi-index-range } related-words diff --git a/extra/gpu/util/wasd/wasd.factor b/extra/gpu/util/wasd/wasd.factor index 34051730fb..b0a3d8179a 100644 --- a/extra/gpu/util/wasd/wasd.factor +++ b/extra/gpu/util/wasd/wasd.factor @@ -8,8 +8,8 @@ specialized-arrays.float ui ui.gadgets.worlds ; IN: gpu.util.wasd UNIFORM-TUPLE: mvp-uniforms - { "mv_matrix" float-uniform { 4 4 } } - { "p_matrix" float-uniform { 4 4 } } ; + { "mv_matrix" mat4-uniform f } + { "p_matrix" mat4-uniform f } ; CONSTANT: -pi/2 $[ pi -2.0 / ] CONSTANT: pi/2 $[ pi 2.0 / ] From bad8e0593765df1d35307445050e8453b397cfa0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Jul 2009 15:48:10 -0500 Subject: [PATCH 34/52] Disallow C functions and parameter names that contain an asterisk --- basis/alien/parser/parser.factor | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index df1dd15bfb..8e050b3950 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -1,11 +1,20 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays assocs effects grouping kernel -parser sequences splitting words fry locals lexer namespaces ; +parser sequences splitting words fry locals lexer namespaces +summary ; IN: alien.parser +ERROR: invalid-c-name name ; + +M: invalid-c-name summary + drop "The C pointer asterisk must be part of the type string." ; + +: check-c-name ( string -- string ) + dup [ CHAR: * = ] any? [ invalid-c-name ] when ; + : parse-arglist ( parameters return -- types effect ) - [ 2 group unzip [ "," ?tail drop ] map ] + [ 2 group unzip [ "," ?tail drop check-c-name ] map ] [ [ { } ] [ 1array ] if-void ] bi* ; @@ -13,7 +22,7 @@ IN: alien.parser '[ _ _ _ _ alien-invoke ] ; :: make-function ( return library function parameters -- word quot effect ) - function create-in dup reset-generic + function check-c-name create-in dup reset-generic return library function parameters return parse-arglist [ function-quot ] dip ; From 78bbf96a6d23ed6799d8a72f93eb2ae30d1c93fd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Jul 2009 15:54:57 -0500 Subject: [PATCH 35/52] move signed-le> to io.binary, clean up using list for math.bitwise --- basis/math/bitwise/bitwise.factor | 13 ++----------- core/io/binary/binary.factor | 7 +++++++ 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index cea944a6e8..bed065a800 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel math sequences accessors -math.bits sequences.private words namespaces macros -hints combinators fry io.binary combinators.smart ; +USING: arrays assocs combinators combinators.smart fry kernel +macros math math.bits sequences sequences.private words ; IN: math.bitwise ! utilities @@ -104,14 +103,6 @@ PRIVATE> : bit-count ( x -- n ) dup 0 < [ bitnot ] when (bit-count) ; inline -! Signed byte array to integer conversion -: signed-le> ( bytes -- x ) - [ le> ] [ length 8 * 1 - on-bits ] bi - 2dup > [ bitnot bitor ] [ drop ] if ; - -: signed-be> ( bytes -- x ) - signed-le> ; - : >signed ( x n -- y ) 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ; diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor index d2e50c2a6a..cf2781aac0 100644 --- a/core/io/binary/binary.factor +++ b/core/io/binary/binary.factor @@ -24,3 +24,10 @@ IN: io.binary : h>b/b ( h -- b1 b2 ) [ mask-byte ] [ -8 shift mask-byte ] bi ; + +: signed-le> ( bytes -- x ) + [ le> ] [ length 8 * 1 - 2^ 1 - ] bi + 2dup > [ bitnot bitor ] [ drop ] if ; + +: signed-be> ( bytes -- x ) + signed-le> ; From 9e7bfc202bce37c339e50fa77cb59f8fa2130a75 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Jul 2009 15:59:55 -0500 Subject: [PATCH 36/52] remove experimental constructors features --- extra/constructors/constructors-tests.factor | 47 +------------------- extra/constructors/constructors.factor | 12 +---- 2 files changed, 4 insertions(+), 55 deletions(-) diff --git a/extra/constructors/constructors-tests.factor b/extra/constructors/constructors-tests.factor index 59ecb8ff77..1e098645bf 100644 --- a/extra/constructors/constructors-tests.factor +++ b/extra/constructors/constructors-tests.factor @@ -29,58 +29,15 @@ CONSTRUCTOR: ct1 ( a -- obj ) [ 1 + ] change-a ; CONSTRUCTOR: ct2 ( a b -- obj ) - initialize-ct1 [ 1 + ] change-a ; CONSTRUCTOR: ct3 ( a b c -- obj ) - initialize-ct1 [ 1 + ] change-a ; CONSTRUCTOR: ct4 ( a b c d -- obj ) - initialize-ct3 [ 1 + ] change-a ; [ 1001 ] [ 1000 a>> ] unit-test [ 2 ] [ 0 0 a>> ] unit-test -[ 2 ] [ 0 0 0 a>> ] unit-test -[ 3 ] [ 0 0 0 0 a>> ] unit-test - - -TUPLE: rofl a b c ; -CONSTRUCTOR: rofl ( b c a -- obj ) ; - -[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 ] unit-test - - -TUPLE: default { a integer initial: 0 } ; - -CONSTRUCTOR: default ( -- obj ) ; - -[ 0 ] [ a>> ] unit-test - - -TUPLE: inherit1 a ; -TUPLE: inherit2 < inherit1 a ; - -CONSTRUCTOR: inherit2 ( a -- obj ) ; - -[ T{ inherit2 f f 100 } ] [ 100 ] unit-test - - -TUPLE: inherit3 hp max-hp ; -TUPLE: inherit4 < inherit3 ; -TUPLE: inherit5 < inherit3 ; - -CONSTRUCTOR: inherit3 ( -- obj ) - dup max-hp>> >>hp ; - -BACKWARD-CONSTRUCTOR: inherit4 ( -- obj ) - 10 >>max-hp ; - -[ 10 ] [ hp>> ] unit-test - -FORWARD-CONSTRUCTOR: inherit5 ( -- obj ) - 5 >>hp - 10 >>max-hp ; - -[ 5 ] [ hp>> ] unit-test +[ 3 ] [ 0 0 0 a>> ] unit-test +[ 4 ] [ 0 0 0 0 a>> ] unit-test diff --git a/extra/constructors/constructors.factor b/extra/constructors/constructors.factor index b8fe598f84..3cee399925 100644 --- a/extra/constructors/constructors.factor +++ b/extra/constructors/constructors.factor @@ -43,12 +43,7 @@ MACRO:: slots>constructor ( class slots -- quot ) class def define-initializer class effect in>> '[ _ _ slots>constructor ] ; -:: define-constructor ( constructor-word class effect def -- ) - constructor-word class effect def (define-constructor) - class lookup-initializer - '[ @ _ execute( obj -- obj ) ] effect define-declared ; - -:: define-auto-constructor ( constructor-word class effect def reverse? -- ) +:: define-constructor ( constructor-word class effect def reverse? -- ) constructor-word class effect def (define-constructor) class superclasses [ lookup-initializer ] map sift reverse? [ reverse ] when @@ -60,9 +55,6 @@ MACRO:: slots>constructor ( class slots -- quot ) : parse-constructor ( -- class word effect def ) scan-constructor complete-effect parse-definition ; -SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ; -SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ; -SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ; -SYNTAX: AUTO-CONSTRUCTOR: parse-constructor f define-auto-constructor ; +SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ; "initializers" create-vocab drop From 37a9f01adced7b062f80b1d4365cf840f0561796 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Jul 2009 17:39:12 -0500 Subject: [PATCH 37/52] fix typo in x11 binding --- basis/x11/xlib/xlib.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 65338dc88b..c8a4bfa0dc 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -477,7 +477,7 @@ C-STRUCT: XImage { "XImage-funcs" "f" } ; X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ; -X-FUNCTION: int XDestroyImage ( XImage *ximage ) ; +X-FUNCTION: int XDestroyImage ( XImage* ximage ) ; : XImage-size ( ximage -- size ) [ XImage-height ] [ XImage-bytes_per_line ] bi * ; From 555309ba864903f1fe271c76cfe2076723532886 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Jul 2009 17:49:04 -0500 Subject: [PATCH 38/52] fix another typo in ffi --- basis/cairo/ffi/ffi.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor index 2930843ad7..ce5f0cc233 100644 --- a/basis/cairo/ffi/ffi.factor +++ b/basis/cairo/ffi/ffi.factor @@ -896,7 +896,7 @@ FUNCTION: cairo_status_t cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ; FUNCTION: cairo_status_t -cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ; +cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t** surface ) ; FUNCTION: cairo_status_t cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ; From 93c58a8bb5ec350dabb2a89ea357dc384a33c810 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Jul 2009 18:02:29 -0500 Subject: [PATCH 39/52] compiler.cfg.branch-splitting: now that we do SSA construction we can split branches with fixnum overflow ops (which have a live-out) --- .../branch-splitting/branch-splitting.factor | 17 ++--------------- 1 file changed, 2 insertions(+), 15 deletions(-) diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor index 2ab476e20c..89e3604aec 100644 --- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor +++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor @@ -6,18 +6,8 @@ compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ; IN: compiler.cfg.branch-splitting -: clone-renamings ( insns -- assoc ) - [ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ; - : clone-instructions ( insns -- insns' ) - dup clone-renamings renamings [ - [ - clone - dup rename-insn-defs - dup rename-insn-uses - dup fresh-insn-temps - ] map - ] with-variable ; + [ clone dup fresh-insn-temps ] map ; : clone-basic-block ( bb -- bb' ) ! The new block gets the same RPO number as the old one. @@ -62,10 +52,7 @@ IN: compiler.cfg.branch-splitting UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ; -: split-instructions? ( insns -- ? ) - [ [ irrelevant? not ] count 5 <= ] - [ last ##fixnum-overflow? not ] - bi and ; +: split-instructions? ( insns -- ? ) [ irrelevant? not ] count 5 <= ; : split-branch? ( bb -- ? ) { From 747a2d72c8903af9e7f5454dc2886a42c4e51e66 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Jul 2009 18:02:46 -0500 Subject: [PATCH 40/52] compiler.cfg.empty-blocks: new pass to delete empty blocks, runs after phi elimination --- .../cfg/empty-blocks/empty-blocks.factor | 38 +++++++++++++++++++ basis/compiler/cfg/optimizer/optimizer.factor | 2 + 2 files changed, 40 insertions(+) create mode 100644 basis/compiler/cfg/empty-blocks/empty-blocks.factor diff --git a/basis/compiler/cfg/empty-blocks/empty-blocks.factor b/basis/compiler/cfg/empty-blocks/empty-blocks.factor new file mode 100644 index 0000000000..2a31a20b72 --- /dev/null +++ b/basis/compiler/cfg/empty-blocks/empty-blocks.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2008, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences combinators combinators.short-circuit +classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ; +IN: compiler.cfg.empty-blocks + +: update-predecessor ( bb -- ) + ! We have to replace occurrences of bb with bb's successor + ! in bb's predecessor's list of successors. + dup predecessors>> first [ + [ + 2dup eq? [ drop successors>> first ] [ nip ] if + ] with map + ] change-successors drop ; + +: update-successor ( bb -- ) + ! We have to replace occurrences of bb with bb's predecessor + ! in bb's sucessor's list of predecessors. + dup successors>> first [ + [ + 2dup eq? [ drop predecessors>> first ] [ nip ] if + ] with map + ] change-predecessors drop ; + +: delete-basic-block ( bb -- ) + [ update-predecessor ] [ update-successor ] bi ; + +: delete-basic-block? ( bb -- ? ) + { + [ instructions>> length 1 = ] + [ predecessors>> length 1 = ] + [ successors>> length 1 = ] + [ instructions>> first ##branch? ] + } 1&& ; + +: delete-empty-blocks ( cfg -- cfg' ) + dup [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if ] each-basic-block + cfg-changed ; \ No newline at end of file diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 1419ff1952..0b37157b43 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -14,6 +14,7 @@ compiler.cfg.dce compiler.cfg.write-barrier compiler.cfg.rpo compiler.cfg.phi-elimination +compiler.cfg.empty-blocks compiler.cfg.checker ; IN: compiler.cfg.optimizer @@ -42,5 +43,6 @@ SYMBOL: check-optimizer? eliminate-dead-code eliminate-write-barriers eliminate-phis + delete-empty-blocks ?check ] with-scope ; From b1afd4c49183c184842759baa0288aaa87e91ef1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Jul 2009 18:03:04 -0500 Subject: [PATCH 41/52] compiler.cfg.linear-scan.mapping: simplify --- basis/compiler/cfg/linear-scan/mapping/mapping.factor | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/mapping/mapping.factor b/basis/compiler/cfg/linear-scan/mapping/mapping.factor index 5b47f33c64..36678a2f53 100644 --- a/basis/compiler/cfg/linear-scan/mapping/mapping.factor +++ b/basis/compiler/cfg/linear-scan/mapping/mapping.factor @@ -44,17 +44,11 @@ M: register->register >insn SYMBOL: froms SYMBOL: tos -SINGLETONS: memory register ; - -: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ; - -: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ; - : from-reg ( operation -- seq ) - [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ; + [ from>> ] [ reg-class>> ] bi 2array ; : to-reg ( operation -- seq ) - [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ; + [ to>> ] [ reg-class>> ] bi 2array ; : start? ( operations -- pair ) from-reg tos get key? not ; From ff7f0e2f3b58b9872287e20b6b538175f9a86f92 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Jul 2009 18:03:14 -0500 Subject: [PATCH 42/52] Add testcase for recent bug --- basis/compiler/tests/codegen.factor | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 4494df1705..c93e20294e 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -321,4 +321,16 @@ cell 4 = [ ] when ! Regression from Slava's value numbering changes -[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test \ No newline at end of file +[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test + +! Bug with ##return node construction +: return-recursive-bug ( nodes -- ? ) + { fixnum } declare [ + dup 3 bitand 1 = [ drop t ] [ + dup 3 bitand 2 = [ + return-recursive-bug + ] [ drop f ] if + ] if + ] any? ; inline recursive + +[ t ] [ 3 [ return-recursive-bug ] compile-call ] unit-test \ No newline at end of file From 9bb38b870c39cb41ca7beb6a8f955b10c8dcb2ff Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Jul 2009 18:05:09 -0500 Subject: [PATCH 43/52] allow FUNCTION: to parse pointers in the name field --- basis/alien/parser/parser.factor | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 8e050b3950..8e2fe82578 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -1,27 +1,30 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays assocs effects grouping kernel parser sequences splitting words fry locals lexer namespaces -summary ; +summary math ; IN: alien.parser -ERROR: invalid-c-name name ; - -M: invalid-c-name summary - drop "The C pointer asterisk must be part of the type string." ; - -: check-c-name ( string -- string ) - dup [ CHAR: * = ] any? [ invalid-c-name ] when ; +: normalize-c-arg ( type name -- type' name' ) + [ length ] + [ + [ CHAR: * = ] trim-head + [ length - CHAR: * append ] keep + ] bi ; : parse-arglist ( parameters return -- types effect ) - [ 2 group unzip [ "," ?tail drop check-c-name ] map ] + [ + 2 group [ first2 normalize-c-arg 2array ] map + unzip [ "," ?tail drop check-c-name ] map + ] [ [ { } ] [ 1array ] if-void ] bi* ; : function-quot ( return library function types -- quot ) '[ _ _ _ _ alien-invoke ] ; -:: make-function ( return library function parameters -- word quot effect ) +:: make-function ( return! library function! parameters -- word quot effect ) + return function normalize-c-arg function! return! function check-c-name create-in dup reset-generic return library function parameters return parse-arglist [ function-quot ] dip ; From f7b2e4a155fd2d297bdd0740f0f2329e8fe98e42 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Jul 2009 18:14:07 -0500 Subject: [PATCH 44/52] remove call to check-c-name --- basis/alien/parser/parser.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 8e2fe82578..19ab08c03c 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -15,7 +15,7 @@ IN: alien.parser : parse-arglist ( parameters return -- types effect ) [ 2 group [ first2 normalize-c-arg 2array ] map - unzip [ "," ?tail drop check-c-name ] map + unzip [ "," ?tail drop ] map ] [ [ { } ] [ 1array ] if-void ] bi* ; @@ -25,7 +25,7 @@ IN: alien.parser :: make-function ( return! library function! parameters -- word quot effect ) return function normalize-c-arg function! return! - function check-c-name create-in dup reset-generic + function create-in dup reset-generic return library function parameters return parse-arglist [ function-quot ] dip ; From d947c61bd7345bd4fbc940c17868e0dcab2ef3fb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Jul 2009 20:54:38 -0500 Subject: [PATCH 45/52] compiler.cfg.stacks: now performs online local DCN --- .../compiler/cfg/builder/blocks/blocks.factor | 74 +++ .../compiler/cfg/builder/builder-tests.factor | 6 +- basis/compiler/cfg/builder/builder.factor | 37 +- basis/compiler/cfg/checker/checker.factor | 6 +- basis/compiler/cfg/dcn/dcn-tests.factor | 620 ------------------ basis/compiler/cfg/dcn/dcn.factor | 44 -- basis/compiler/cfg/dcn/height/height.factor | 82 --- basis/compiler/cfg/dcn/local/local.factor | 101 --- .../cfg/instructions/instructions.factor | 2 +- .../cfg/intrinsics/alien/alien.factor | 9 +- .../cfg/intrinsics/allot/allot.factor | 4 +- .../cfg/intrinsics/fixnum/fixnum.factor | 9 +- .../cfg/intrinsics/slots/slots.factor | 4 +- .../cfg/linearization/linearization.factor | 7 +- basis/compiler/cfg/optimizer/optimizer.factor | 2 - .../finalize/finalize.factor} | 43 +- .../cfg/{dcn => stacks}/global/global.factor | 15 +- .../compiler/cfg/stacks/height/height.factor | 27 + basis/compiler/cfg/stacks/local/local.factor | 80 +++ basis/compiler/cfg/stacks/stacks.factor | 67 +- basis/compiler/cfg/utilities/utilities.factor | 36 - 21 files changed, 295 insertions(+), 980 deletions(-) create mode 100644 basis/compiler/cfg/builder/blocks/blocks.factor delete mode 100644 basis/compiler/cfg/dcn/dcn-tests.factor delete mode 100644 basis/compiler/cfg/dcn/dcn.factor delete mode 100644 basis/compiler/cfg/dcn/height/height.factor delete mode 100644 basis/compiler/cfg/dcn/local/local.factor rename basis/compiler/cfg/{dcn/rewrite/rewrite.factor => stacks/finalize/finalize.factor} (51%) rename basis/compiler/cfg/{dcn => stacks}/global/global.factor (65%) create mode 100644 basis/compiler/cfg/stacks/height/height.factor create mode 100644 basis/compiler/cfg/stacks/local/local.factor diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor new file mode 100644 index 0000000000..4f4f9ad7b3 --- /dev/null +++ b/basis/compiler/cfg/builder/blocks/blocks.factor @@ -0,0 +1,74 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays fry kernel make math namespaces sequences +compiler.cfg compiler.cfg.instructions compiler.cfg.stacks +compiler.cfg.stacks.local ; +IN: compiler.cfg.builder.blocks + +: set-basic-block ( basic-block -- ) + [ basic-block set ] [ instructions>> building set ] bi + begin-local-analysis ; + +: initial-basic-block ( -- ) + set-basic-block ; + +: end-basic-block ( -- ) + basic-block get [ end-local-analysis ] when + building off + basic-block off ; + +: (begin-basic-block) ( -- ) + + basic-block get [ dupd successors>> push ] when* + set-basic-block ; + +: begin-basic-block ( -- ) + basic-block get [ end-local-analysis ] when + (begin-basic-block) ; + +: emit-trivial-block ( quot -- ) + building get empty? [ ##branch begin-basic-block ] unless + call + ##branch begin-basic-block ; inline + +: call-height ( #call -- n ) + [ out-d>> length ] [ in-d>> length ] bi - ; + +: emit-primitive ( node -- ) + [ + [ word>> ##call ] + [ call-height adjust-d ] bi + ] emit-trivial-block ; + +: begin-branch ( -- ) clone-current-height (begin-basic-block) ; + +: end-branch ( -- pair/f ) + ! pair is { final-bb final-height } + basic-block get dup [ + ##branch + end-local-analysis + current-height get clone 2array + ] when ; + +: with-branch ( quot -- pair/f ) + [ begin-branch call end-branch ] with-scope ; inline + +: set-successors ( branches -- ) + ! Set the successor of each branch's final basic block to the + ! current block. + basic-block get dup [ + '[ [ [ _ ] dip first successors>> push ] when* ] each + ] [ 2drop ] if ; + +: merge-heights ( branches -- ) + ! If all elements are f, that means every branch ended with a backward + ! jump so the height is irrelevant since this block is unreachable. + [ ] find nip [ second current-height set ] [ end-basic-block ] if* ; + +: emit-conditional ( branches -- ) + ! branchies is a sequence of pairs as above + end-basic-block + [ merge-heights begin-basic-block ] + [ set-successors ] + bi ; + diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 7381bdca55..812ef18e86 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -2,12 +2,12 @@ IN: compiler.cfg.builder.tests USING: tools.test kernel sequences words sequences.private fry prettyprint alien alien.accessors math.private compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger -compiler.cfg.predecessors compiler.cfg.checker arrays locals -byte-arrays kernel.private math slots.private ; +compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker +arrays locals byte-arrays kernel.private math slots.private ; ! Just ensure that various CFGs build correctly. : unit-test-cfg ( quot -- ) - '[ _ test-cfg [ compute-predecessors check-cfg ] each ] [ ] swap unit-test ; + '[ _ test-cfg [ optimize-cfg check-cfg ] each ] [ ] swap unit-test ; : blahblah ( nodes -- ? ) { fixnum } declare [ diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 7a7156d5c9..7a877ad49f 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -10,30 +10,39 @@ compiler.tree.combinators compiler.tree.propagation.info compiler.cfg compiler.cfg.hats -compiler.cfg.stacks compiler.cfg.utilities compiler.cfg.registers compiler.cfg.intrinsics compiler.cfg.comparisons compiler.cfg.stack-frame compiler.cfg.instructions +compiler.cfg.predecessors +compiler.cfg.builder.blocks +compiler.cfg.stacks compiler.alien ; IN: compiler.cfg.builder -! Convert tree SSA IR to CFG SSA IR. +! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is +! constructed later by calling compiler.cfg.ssa:construct-ssa. SYMBOL: procedures SYMBOL: loops -: begin-procedure ( word label -- ) - end-basic-block - begin-basic-block +: begin-cfg ( word label -- cfg ) + initial-basic-block H{ } clone loops set - [ basic-block get ] 2dip - procedures get push ; + [ basic-block get ] 2dip dup cfg set ; + +: begin-procedure ( word label -- ) + begin-cfg procedures get push ; : with-cfg-builder ( nodes word label quot -- ) - '[ begin-procedure @ ] with-scope ; inline + '[ + begin-stack-analysis + begin-procedure + @ + end-stack-analysis + ] with-scope ; inline GENERIC: emit-node ( node -- ) @@ -61,7 +70,7 @@ GENERIC: emit-node ( node -- ) : emit-loop-call ( basic-block -- ) ##branch basic-block get successors>> push - basic-block off ; + end-basic-block ; : emit-trivial-block ( quot -- ) basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless @@ -71,7 +80,7 @@ GENERIC: emit-node ( node -- ) : emit-call ( word height -- ) over loops get key? [ drop loops get at emit-loop-call ] - [ [ ##call ] emit-trivial-block ] + [ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ] if ; ! #recursive @@ -169,7 +178,7 @@ M: #return-recursive emit-node label>> id>> loops get key? [ emit-return ] unless ; ! #terminate -M: #terminate emit-node drop ##no-tco basic-block off ; +M: #terminate emit-node drop ##no-tco end-basic-block ; ! FFI : return-size ( ctype -- n ) @@ -186,9 +195,13 @@ M: #terminate emit-node drop ##no-tco basic-block off ; [ return>> return-size >>return ] [ alien-parameters parameter-sizes drop >>params ] bi ; +: alien-node-height ( params -- n ) + [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; + : emit-alien-node ( node quot -- ) [ - [ params>> dup ] dip call + [ params>> dup dup ] dip call + alien-node-height ] emit-trivial-block ; inline M: #alien-invoke emit-node diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 53f84b1dda..22b6f03231 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities -compiler.cfg.dce compiler.cfg.mr combinators.short-circuit accessors -math sequences sets assocs ; +compiler.cfg.mr combinators.short-circuit accessors math +sequences sets assocs ; IN: compiler.cfg.checker ERROR: bad-kill-block bb ; @@ -64,5 +64,5 @@ ERROR: undefined-values uses defs ; : check-cfg ( cfg -- ) [ [ check-basic-block ] each-basic-block ] - [ eliminate-dead-code build-mr check-mr ] + [ build-mr check-mr ] bi ; diff --git a/basis/compiler/cfg/dcn/dcn-tests.factor b/basis/compiler/cfg/dcn/dcn-tests.factor deleted file mode 100644 index c987d9edd2..0000000000 --- a/basis/compiler/cfg/dcn/dcn-tests.factor +++ /dev/null @@ -1,620 +0,0 @@ -IN: compiler.cfg.dcn.tests -USING: tools.test kernel accessors namespaces assocs math -cpu.architecture vectors sequences classes -compiler.cfg -compiler.cfg.utilities -compiler.cfg.debugger -compiler.cfg.registers -compiler.cfg.predecessors -compiler.cfg.instructions -compiler.cfg.checker -compiler.cfg.dcn -compiler.cfg.dcn.height -compiler.cfg.dcn.local -compiler.cfg.dcn.local.private -compiler.cfg.dcn.global -compiler.cfg.dcn.rewrite ; - -: test-local-dcn ( insns -- insns' ) - swap >>instructions - [ local-analysis ] keep - instructions>> ; - -: inserting-peeks' ( from to -- assoc ) - [ inserting-peeks ] keep untranslate-locs keys ; - -: inserting-replaces' ( from to -- assoc ) - [ inserting-replaces ] keep untranslate-locs [ drop n>> 0 >= ] assoc-filter keys ; - -[ - V{ - T{ ##copy f V int-regs 1 V int-regs 0 } - T{ ##copy f V int-regs 3 V int-regs 2 } - T{ ##copy f V int-regs 5 V int-regs 4 } - T{ ##inc-d f -1 } - T{ ##branch } - } -] [ - V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 0 } - T{ ##inc-d f -1 } - T{ ##peek f V int-regs 2 D 0 } - T{ ##peek f V int-regs 3 D 0 } - T{ ##replace f V int-regs 2 D 0 } - T{ ##replace f V int-regs 4 D 1 } - T{ ##peek f V int-regs 5 D 1 } - T{ ##replace f V int-regs 5 D 1 } - T{ ##replace f V int-regs 6 D -1 } - T{ ##branch } - } test-local-dcn -] unit-test - -[ - H{ - { V int-regs 1 V int-regs 0 } - { V int-regs 3 V int-regs 2 } - { V int-regs 5 V int-regs 4 } - } -] [ - copies get -] unit-test - -[ - H{ - { D 0 V int-regs 0 } - { D 1 V int-regs 2 } - } -] [ reads-locations get ] unit-test - -[ - H{ - { D 0 V int-regs 6 } - { D 2 V int-regs 4 } - } -] [ writes-locations get ] unit-test - -: test-global-dcn ( -- ) - cfg new 0 get >>entry - compute-predecessors - deconcatenatize - drop ; - -V{ T{ ##epilogue } T{ ##return } } 0 test-bb - -[ ] [ test-global-dcn ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##inc-d f 1 } - T{ ##peek f V int-regs 0 D 1 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##replace f V int-regs 1 D 2 } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 2 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 1vector >>successors drop - -[ t ] [ 0 get kill-block? ] unit-test -[ t ] [ 2 get kill-block? ] unit-test - -[ ] [ test-global-dcn ] unit-test - -[ t ] [ D 0 1 get peek-in key? ] unit-test - -[ f ] [ D 0 0 get peek-in key? ] unit-test - -[ t ] [ D 0 1 get avail-out key? ] unit-test - -[ f ] [ D 0 0 get avail-out key? ] unit-test - -[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test - -[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test - -[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test - -[ { D 2 } ] [ 1 get 2 get inserting-replaces' ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek f V int-regs 0 D 1 } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##inc-d f -1 } - T{ ##peek f V int-regs 0 D 0 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 3 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 1vector >>successors drop -2 get 3 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ t ] [ D 1 2 get peek-in key? ] unit-test -[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##branch } -} 1 test-bb - -V{ - T{ ##inc-d f 1 } - T{ ##peek f V int-regs 0 D 1 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 3 test-bb - -V{ - T{ ##peek f V int-regs 1 D 0 } - T{ ##peek f V int-regs 2 D 1 } - T{ ##inc-d f 1 } - T{ ##replace f V int-regs 2 D 1 } - T{ ##branch } -} 4 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 5 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 4 get V{ } 2sequence >>successors drop -2 get 3 get 1vector >>successors drop -4 get 5 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ f ] [ D 0 1 get avail-out key? ] unit-test -[ f ] [ D 1 1 get avail-out key? ] unit-test -[ t ] [ D 0 4 get peek-in key? ] unit-test -[ t ] [ D 1 4 get peek-in key? ] unit-test - -[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test -[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test -[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test -[ { D 1 } ] [ 1 get 4 get inserting-peeks' ] unit-test -[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test -[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test -[ { D 1 } ] [ 4 get 5 get inserting-replaces' ] unit-test - -[ t ] [ D 0 1 get peek-out key? ] unit-test -[ f ] [ D 1 1 get peek-out key? ] unit-test - -[ t ] [ D 1 4 get peek-in key? ] unit-test -[ f ] [ D 1 4 get avail-in key? ] unit-test -[ t ] [ D 1 4 get avail-out key? ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##peek f V int-regs 1 D 1 } - T{ ##inc-d f -1 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##load-immediate f V int-regs 2 100 } - T{ ##replace f V int-regs 2 D 1 } - T{ ##inc-d f -1 } - T{ ##peek f V int-regs 4 D 1 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##load-immediate f V int-regs 3 100 } - T{ ##replace f V int-regs 3 D 0 } - T{ ##branch } -} 4 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 5 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 3 get V{ } 2sequence >>successors drop -2 get 4 get 1vector >>successors drop -3 get 4 get 1vector >>successors drop -4 get 5 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ t ] [ D 1 4 get avail-in key? ] unit-test -[ f ] [ D 2 4 get avail-in key? ] unit-test -[ t ] [ D 1 2 get peek-in key? ] unit-test -[ f ] [ D 1 3 get peek-in key? ] unit-test - -[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test -[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test -[ { D 1 } ] [ 1 get 2 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test -[ { D 2 } ] [ 1 get 3 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test -[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test -[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test -[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test -[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek f V int-regs 0 D 1 } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##inc-d f -1 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##call f drop -1 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##peek f V int-regs 1 D 0 } - T{ ##branch } -} 4 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 5 test-bb - -[ t ] [ 0 get kill-block? ] unit-test -[ t ] [ 3 get kill-block? ] unit-test - -0 get 1 get 1vector >>successors drop -1 get 2 get 3 get V{ } 2sequence >>successors drop -2 get 4 get 1vector >>successors drop -3 get 4 get 1vector >>successors drop -4 get 5 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ t ] [ D 1 2 get avail-out key? ] unit-test -[ f ] [ D 1 3 get peek-out key? ] unit-test -[ f ] [ D 1 3 get avail-out key? ] unit-test -[ f ] [ D 1 4 get avail-in key? ] unit-test - -[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test -[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test -[ { D 0 } ] [ 3 get 4 get inserting-peeks' ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##branch } -} 1 test-bb - -V{ T{ ##epilogue } T{ ##return } } 2 test-bb - -V{ T{ ##branch } } 3 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 3 get V{ } 2sequence >>successors drop -3 get 1 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ t ] [ D 0 1 get avail-out key? ] unit-test - -[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test -[ { } ] [ 3 get 1 get inserting-peeks' ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##branch } -} 1 test-bb - -V{ - T{ ##call f drop } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##branch } -} 3 test-bb - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##branch } -} 4 test-bb - -V{ - T{ ##peek f V int-regs 1 D 0 } - T{ ##branch } -} 5 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 6 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 3 get V{ } 2sequence >>successors drop -2 get 4 get 1vector >>successors drop -3 get 4 get 1vector >>successors drop -4 get 5 get 1vector >>successors drop -5 get 6 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ { } ] [ 0 get 1 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test -[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test -[ { D 0 } ] [ 2 get 4 get inserting-peeks' ] unit-test -[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test -[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test -[ { } ] [ 5 get 6 get inserting-peeks' ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##branch } -} 1 test-bb - -V{ - T{ ##load-immediate f V int-regs 1 100 } - T{ ##replace f V int-regs 1 D 0 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##peek f V int-regs 2 D 0 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##branch } -} 4 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 5 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 3 get V{ } 2sequence >>successors drop -2 get 4 get 1vector >>successors drop -3 get 4 get 1vector >>successors drop -4 get 5 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test -[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test -[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test -[ { D 0 } ] [ 2 get 4 get inserting-replaces' ] unit-test -[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test -[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test -[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test -[ { } ] [ 4 get 5 get inserting-replaces' ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##branch } -} 1 test-bb - -V{ - T{ ##load-immediate f V int-regs 1 100 } - T{ ##replace f V int-regs 1 D 0 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##load-immediate f V int-regs 2 100 } - T{ ##replace f V int-regs 2 D 0 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##branch } -} 4 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 5 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 3 get V{ } 2sequence >>successors drop -2 get 4 get 1vector >>successors drop -3 get 4 get 1vector >>successors drop -4 get 5 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test - -[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test - -[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test - -! Dead replace elimination -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##replace f V int-regs 1 D 0 } - T{ ##replace f V int-regs 0 D 1 } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##inc-d f -2 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 3 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 1vector >>successors drop -2 get 3 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test -[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test -[ { } ] [ 2 get 3 get inserting-replaces' ] unit-test - -! More dead replace elimination tests -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek { dst V int-regs 10 } { loc D 0 } } - T{ ##inc-d { n -1 } } - T{ ##inc-r { n 1 } } - T{ ##replace { src V int-regs 10 } { loc R 0 } } - T{ ##peek { dst V int-regs 12 } { loc R 0 } } - T{ ##inc-r { n -1 } } - T{ ##inc-d { n 1 } } - T{ ##replace { src V int-regs 12 } { loc D 0 } } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 2 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test - -! Check that retain stack usage works -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##inc-d f -1 } - T{ ##inc-r f 1 } - T{ ##replace f V int-regs 0 R 0 } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##call f + -1 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##peek f V int-regs 0 R 0 } - T{ ##inc-r f -1 } - T{ ##inc-d f 1 } - T{ ##replace f V int-regs 0 D 0 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 4 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 1vector >>successors drop -2 get 3 get 1vector >>successors drop -3 get 4 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ ##replace D 0 ] [ - 3 get successors>> first instructions>> first - [ class ] [ loc>> ] bi -] unit-test - -[ ##replace R 0 ] [ - 1 get successors>> first instructions>> first - [ class ] [ loc>> ] bi -] unit-test - -[ ##peek R 0 ] [ - 2 get successors>> first instructions>> first - [ class ] [ loc>> ] bi -] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/dcn/dcn.factor b/basis/compiler/cfg/dcn/dcn.factor deleted file mode 100644 index e2e52b30d5..0000000000 --- a/basis/compiler/cfg/dcn/dcn.factor +++ /dev/null @@ -1,44 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: combinators -compiler.cfg -compiler.cfg.dcn.height -compiler.cfg.dcn.local -compiler.cfg.dcn.global -compiler.cfg.dcn.rewrite ; -IN: compiler.cfg.dcn - -! "DeConcatenatizatioN" -- dataflow analysis to recover registers -! from stack locations. - -! Local sets: -! - P(b): locations that block b peeks before replacing -! - R(b): locations that block b replaces -! - A(b): P(b) \/ R(b) -- locations that are available in registers at the end of b - -! Global sets: -! - P_out(b) = /\ P_in(sux) for sux in successors(b) -! - P_in(b) = (P_out(b) - R(b)) \/ P(b) -! -! - R_in(b) = R_out(b) \/ R(b) -! - R_out(b) = \/ R_in(sux) for sux in successors(b) -! -! - A_in(b) = /\ A_out(pred) for pred in predecessors(b) -! - A_out(b) = A_in(b) \/ P(b) \/ R(b) - -! On every edge [b --> sux], insert a replace for each location in -! R_out(b) - R_in(sux) - -! On every edge [pred --> b], insert a peek for each location in -! P_in(b) - (P_out(pred) \/ A_out(pred)) - -! Locations are height-normalized. - -: deconcatenatize ( cfg -- cfg' ) - { - [ compute-heights ] - [ compute-local-sets ] - [ compute-global-sets ] - [ rewrite ] - [ cfg-changed ] - } cleave ; \ No newline at end of file diff --git a/basis/compiler/cfg/dcn/height/height.factor b/basis/compiler/cfg/dcn/height/height.factor deleted file mode 100644 index 1a59ddcb35..0000000000 --- a/basis/compiler/cfg/dcn/height/height.factor +++ /dev/null @@ -1,82 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs accessors sequences kernel math locals fry -compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.registers ; -IN: compiler.cfg.dcn.height - -! Compute block in-height and out-height sets. These are relative to the -! stack height from the start of the procedure. - -> ; - -M: ##call ds-height-change height>> ; - -: alien-node-height ( node -- n ) - params>> [ out-d>> length ] [ in-d>> length ] bi - ; - -M: ##alien-invoke ds-height-change alien-node-height ; - -M: ##alien-indirect ds-height-change alien-node-height ; - -GENERIC: rs-height-change ( insn -- n ) - -M: insn rs-height-change drop 0 ; - -M: ##inc-r rs-height-change n>> ; - -:: compute-in-height ( bb in out -- ) - bb predecessors>> [ out at ] map-find drop 0 or - bb in set-at ; - -:: compute-out-height ( bb in out quot -- ) - bb instructions>> - bb in at - [ quot call + ] reduce - bb out set-at ; inline - -:: compute-height ( bb in out quot -- ) - bb in get out get - [ compute-in-height ] - [ quot compute-out-height ] 3bi ; inline - -: compute-ds-height ( bb -- ) - in-ds-heights out-ds-heights [ ds-height-change ] compute-height ; - -: compute-rs-height ( bb -- ) - in-rs-heights out-rs-heights [ rs-height-change ] compute-height ; - -PRIVATE> - -: compute-heights ( cfg -- ) - H{ } clone in-ds-heights set - H{ } clone out-ds-heights set - H{ } clone in-rs-heights set - H{ } clone out-rs-heights set - [ - [ compute-rs-height ] - [ compute-ds-height ] bi - ] each-basic-block ; - -GENERIC# translate-loc 1 ( loc bb -- loc' ) - -M: ds-loc translate-loc [ n>> ] [ in-ds-heights get at ] bi* - ; -M: rs-loc translate-loc [ n>> ] [ in-rs-heights get at ] bi* - ; - -: translate-locs ( assoc bb -- assoc' ) - '[ [ _ translate-loc ] dip ] assoc-map ; - -GENERIC# untranslate-loc 1 ( loc bb -- loc' ) - -M: ds-loc untranslate-loc [ n>> ] [ in-ds-heights get at ] bi* + ; -M: rs-loc untranslate-loc [ n>> ] [ in-rs-heights get at ] bi* + ; - -: untranslate-locs ( assoc bb -- assoc' ) - '[ [ _ untranslate-loc ] dip ] assoc-map ; diff --git a/basis/compiler/cfg/dcn/local/local.factor b/basis/compiler/cfg/dcn/local/local.factor deleted file mode 100644 index 3ed543f868..0000000000 --- a/basis/compiler/cfg/dcn/local/local.factor +++ /dev/null @@ -1,101 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel make namespaces sequences math -compiler.cfg.rpo compiler.cfg.registers compiler.cfg.instructions -compiler.cfg.dcn.height ; -IN: compiler.cfg.dcn.local - -vreg ( loc -- vreg ) - dup writes-locations get at - [ ] [ reads-locations get at ] ?if ; - -SYMBOL: ds-height - -SYMBOL: rs-height - -GENERIC: translate-loc ( loc -- loc' ) - -M: ds-loc translate-loc n>> ds-height get - ; - -M: rs-loc translate-loc n>> rs-height get - ; - -GENERIC: visit ( insn -- ) - -M: insn visit , ; - -M: ##inc-d visit n>> ds-height [ + ] change ; - -M: ##inc-r visit n>> rs-height [ + ] change ; - -M: ##peek visit - ! If location is in a register already, copy existing - ! register to destination. Otherwise, associate the - ! location with the register. - [ dst>> ] [ loc>> translate-loc ] bi dup loc>vreg - [ [ record-copy ] [ ##copy ] 2bi ] - [ reads-locations get set-at ] - ?if ; - -M: ##replace visit - ! If location already contains the same value, do nothing. - ! Otherwise, associate the location with the register. - [ src>> resolve-copy ] [ loc>> translate-loc ] bi 2dup loc>vreg = - [ 2drop ] [ writes-locations get set-at ] if ; - -M: ##copy visit - ! Not needed at this point because IR doesn't have ##copy - ! on input to dcn pass, but in the future it might. - [ dst>> ] [ src>> resolve-copy ] bi record-copy ; - -: insert-height-changes ( -- ) - ds-height get dup 0 = [ drop ] [ ##inc-d ] if - rs-height get dup 0 = [ drop ] [ ##inc-r ] if ; - -: init-local-analysis ( -- ) - 0 ds-height set - 0 rs-height set - H{ } clone copies set - H{ } clone reads-locations set - H{ } clone writes-locations set ; - -: local-analysis ( bb -- ) - ! Removes all ##peek and ##replace from the basic block. - ! Conceptually, moves all ##peeks to the start - ! (reads-locations assoc) and all ##replaces to the end - ! (writes-locations assoc). - init-local-analysis - [ - [ - unclip-last-slice [ [ visit ] each ] dip - insert-height-changes - , - ] V{ } make - ] change-instructions drop ; - -SYMBOLS: peeks replaces ; - -: visit-block ( bb -- ) - [ local-analysis ] - [ [ reads-locations get ] dip [ translate-locs ] keep peeks get set-at ] - [ [ writes-locations get ] dip [ translate-locs ] keep replaces get set-at ] - tri ; - -PRIVATE> - -: peek ( bb -- assoc ) peeks get at ; -: replace ( bb -- assoc ) replaces get at ; - -: compute-local-sets ( cfg -- ) - H{ } clone peeks set - H{ } clone replaces set - [ visit-block ] each-basic-block ; \ No newline at end of file diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 2496b29ae2..07ebcc3ba9 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -52,7 +52,7 @@ INSN: ##inc-d { n integer } ; INSN: ##inc-r { n integer } ; ! Subroutine calls -INSN: ##call word { height integer } ; +INSN: ##call word ; INSN: ##jump word ; INSN: ##return ; diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index 42e23c29c9..04d841f2d1 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -1,10 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences alien math classes.algebra -fry locals combinators cpu.architecture -compiler.tree.propagation.info +USING: accessors kernel sequences alien math classes.algebra fry +locals combinators cpu.architecture compiler.tree.propagation.info compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions -compiler.cfg.utilities ; +compiler.cfg.utilities compiler.cfg.builder.blocks ; IN: compiler.cfg.intrinsics.alien : (prepare-alien-accessor-imm) ( class offset -- offset-vreg ) diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 7b407c3ee4..8afd9f80ca 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.order sequences accessors arrays byte-arrays layouts classes.tuple.private fry locals compiler.tree.propagation.info compiler.cfg.hats compiler.cfg.instructions compiler.cfg.stacks -compiler.cfg.utilities ; +compiler.cfg.utilities compiler.cfg.builder.blocks ; IN: compiler.cfg.intrinsics.allot : ##set-slots ( regs obj class -- ) diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index cfc07624fe..0eeeb0b12d 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -7,6 +7,7 @@ compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions compiler.cfg.utilities +compiler.cfg.builder.blocks compiler.cfg.registers compiler.cfg.comparisons ; IN: compiler.cfg.intrinsics.fixnum @@ -31,7 +32,7 @@ IN: compiler.cfg.intrinsics.fixnum [ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ; : emit-fixnum-shift-general ( -- ) - D 0 ^^peek 0 cc> ##compare-imm-branch + ds-peek 0 cc> ##compare-imm-branch [ emit-fixnum-left-shift ] with-branch [ emit-fixnum-right-shift ] with-branch 2array emit-conditional ; @@ -62,13 +63,13 @@ IN: compiler.cfg.intrinsics.fixnum ds-pop ^^untag-fixnum ^^integer>bignum ds-push ; : emit-no-overflow-case ( dst -- final-bb ) - [ -2 ##inc-d ds-push ] with-branch ; + [ ds-drop ds-drop ds-push ] with-branch ; : emit-overflow-case ( word -- final-bb ) - [ -1 ##call ] with-branch ; + [ ##call -1 adjust-d ] with-branch ; : emit-fixnum-overflow-op ( quot word -- ) - [ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip + [ [ (2inputs) ] dip call ] dip [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array emit-conditional ; inline diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index 0cc6e6f5d0..93139a19a3 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: layouts namespaces kernel accessors sequences classes.algebra compiler.tree.propagation.info compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions -compiler.cfg.utilities ; +compiler.cfg.utilities compiler.cfg.builder.blocks ; IN: compiler.cfg.intrinsics.slots : value-tag ( info -- n ) class>> class-tag ; inline diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 1f00913b1e..f9e0e54afc 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -25,11 +25,12 @@ M: insn linearize-insn , drop ; #! don't need to branch. [ number>> ] bi@ 1 - = ; inline -: emit-loop-entry? ( bb -- ? ) - dup predecessors>> [ swap back-edge? ] with any? ; +: emit-loop-entry? ( bb successor -- ? ) + [ back-edge? not ] + [ nip dup predecessors>> [ swap back-edge? ] with any? ] 2bi and ; : emit-branch ( bb successor -- ) - dup emit-loop-entry? [ _loop-entry ] when + 2dup emit-loop-entry? [ _loop-entry ] when 2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ; M: ##branch linearize-insn diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 0b37157b43..e4ad290097 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -4,7 +4,6 @@ USING: kernel sequences accessors combinators namespaces compiler.cfg.tco compiler.cfg.predecessors compiler.cfg.useless-conditionals -compiler.cfg.dcn compiler.cfg.ssa compiler.cfg.branch-splitting compiler.cfg.block-joining @@ -35,7 +34,6 @@ SYMBOL: check-optimizer? split-branches join-blocks compute-predecessors - deconcatenatize construct-ssa alias-analysis value-numbering diff --git a/basis/compiler/cfg/dcn/rewrite/rewrite.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor similarity index 51% rename from basis/compiler/cfg/dcn/rewrite/rewrite.factor rename to basis/compiler/cfg/stacks/finalize/finalize.factor index bbc6783f79..5c8c1343d0 100644 --- a/basis/compiler/cfg/dcn/rewrite/rewrite.factor +++ b/basis/compiler/cfg/stacks/finalize/finalize.factor @@ -2,13 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs kernel fry accessors sequences make math combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions -compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.dcn.local -compiler.cfg.dcn.global compiler.cfg.dcn.height ; -IN: compiler.cfg.dcn.rewrite +compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.stacks.local +compiler.cfg.stacks.global compiler.cfg.stacks.height ; +IN: compiler.cfg.stacks.finalize -! This pass inserts peeks, replaces, and copies. All stack locations -! are loaded to canonical vregs, with a 1-1 mapping from location to -! vreg. SSA is reconstructed afterwards. +! This pass inserts peeks and replaces. : inserting-peeks ( from to -- assoc ) peek-in swap [ peek-out ] [ avail-out ] bi @@ -18,10 +16,6 @@ IN: compiler.cfg.dcn.rewrite [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi* assoc-union assoc-diff ; -SYMBOL: locs>vregs - -: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ; - : each-insertion ( assoc bb quot: ( vreg loc -- ) -- ) '[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline @@ -39,30 +33,9 @@ ERROR: bad-peek dst loc ; 2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make [ 2drop ] [ insert-basic-block ] if-empty ; -: visit-edges ( bb -- ) +: visit-block ( bb -- ) [ predecessors>> ] keep '[ _ visit-edge ] each ; -: insert-in-copies ( bb -- ) - peek [ swap loc>vreg ##copy ] assoc-each ; - -: insert-out-copies ( bb -- ) - replace [ swap loc>vreg swap ##copy ] assoc-each ; - -: rewrite-instructions ( bb -- ) - [ - [ - { - [ insert-in-copies ] - [ instructions>> but-last-slice % ] - [ insert-out-copies ] - [ instructions>> last , ] - } cleave - ] V{ } make - ] keep (>>instructions) ; - -: visit-block ( bb -- ) - [ visit-edges ] [ rewrite-instructions ] bi ; - -: rewrite ( cfg -- ) - H{ } clone locs>vregs set - [ visit-block ] each-basic-block ; \ No newline at end of file +: finalize-stack-shuffling ( cfg -- cfg' ) + dup [ visit-block ] each-basic-block + cfg-changed ; \ No newline at end of file diff --git a/basis/compiler/cfg/dcn/global/global.factor b/basis/compiler/cfg/stacks/global/global.factor similarity index 65% rename from basis/compiler/cfg/dcn/global/global.factor rename to basis/compiler/cfg/stacks/global/global.factor index 21a795151a..129d7e74cd 100644 --- a/basis/compiler/cfg/dcn/global/global.factor +++ b/basis/compiler/cfg/stacks/global/global.factor @@ -1,38 +1,39 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel combinators compiler.cfg.dataflow-analysis -compiler.cfg.dcn.local ; -IN: compiler.cfg.dcn.global +compiler.cfg.stacks.local ; +IN: compiler.cfg.stacks.global ! Peek analysis. Peek-in is the set of all locations anticipated at ! the start of a basic block. BACKWARD-ANALYSIS: peek -M: peek-analysis transfer-set drop [ replace assoc-diff ] keep peek assoc-union ; +M: peek-analysis transfer-set drop [ replace-set assoc-diff ] keep peek-set assoc-union ; ! Replace analysis. Replace-in is the set of all locations which ! will be overwritten at some point after the start of a basic block. FORWARD-ANALYSIS: replace -M: replace-analysis transfer-set drop replace assoc-union ; +M: replace-analysis transfer-set drop replace-set assoc-union ; ! Availability analysis. Avail-out is the set of all locations ! in registers at the end of a basic block. FORWARD-ANALYSIS: avail -M: avail-analysis transfer-set drop [ peek ] [ replace ] bi assoc-union assoc-union ; +M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union assoc-union ; ! Kill analysis. Kill-in is the set of all locations ! which are going to be overwritten. BACKWARD-ANALYSIS: kill -M: kill-analysis transfer-set drop replace assoc-union ; +M: kill-analysis transfer-set drop replace-set assoc-union ; ! Main word -: compute-global-sets ( cfg -- ) +: compute-global-sets ( cfg -- cfg' ) { [ compute-peek-sets ] [ compute-replace-sets ] [ compute-avail-sets ] [ compute-kill-sets ] + [ ] } cleave ; \ No newline at end of file diff --git a/basis/compiler/cfg/stacks/height/height.factor b/basis/compiler/cfg/stacks/height/height.factor new file mode 100644 index 0000000000..4d91dc614a --- /dev/null +++ b/basis/compiler/cfg/stacks/height/height.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry kernel math +namespaces compiler.cfg.registers ; +IN: compiler.cfg.stacks.height + +! Global stack height tracking done while constructing CFG. +SYMBOLS: ds-heights rs-heights ; + +: record-stack-heights ( ds-height rs-height bb -- ) + [ ds-heights get set-at ] [ rs-heights get set-at ] bi-curry bi* ; + +GENERIC# translate-loc 1 ( loc bb -- loc' ) + +M: ds-loc translate-loc [ n>> ] [ ds-heights get at ] bi* - ; +M: rs-loc translate-loc [ n>> ] [ rs-heights get at ] bi* - ; + +: translate-locs ( assoc bb -- assoc' ) + '[ [ _ translate-loc ] dip ] assoc-map ; + +GENERIC# untranslate-loc 1 ( loc bb -- loc' ) + +M: ds-loc untranslate-loc [ n>> ] [ ds-heights get at ] bi* + ; +M: rs-loc untranslate-loc [ n>> ] [ rs-heights get at ] bi* + ; + +: untranslate-locs ( assoc bb -- assoc' ) + '[ [ _ untranslate-loc ] dip ] assoc-map ; \ No newline at end of file diff --git a/basis/compiler/cfg/stacks/local/local.factor b/basis/compiler/cfg/stacks/local/local.factor new file mode 100644 index 0000000000..a484464a59 --- /dev/null +++ b/basis/compiler/cfg/stacks/local/local.factor @@ -0,0 +1,80 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel math namespaces sets make sequences +compiler.cfg compiler.cfg.hats +compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.stacks.height ; +IN: compiler.cfg.stacks.local + +! Local stack analysis. We build local peek and replace sets for every basic +! block while constructing the CFG. + +SYMBOLS: peek-sets replace-sets ; + +SYMBOL: locs>vregs + +: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ; + +TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ; + +SYMBOLS: copies local-peek-set local-replace-set ; + +: record-copy ( dst src -- ) swap copies get set-at ; +: resolve-copy ( vreg -- vreg' ) copies get ?at drop ; + +GENERIC: translate-local-loc ( loc -- loc' ) +M: ds-loc translate-local-loc n>> current-height get d>> - ; +M: rs-loc translate-local-loc n>> current-height get r>> - ; + +: emit-height-changes ( -- ) + ! Insert height changes prior to the last instruction + building get pop + current-height get + [ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ] + [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi + , ; + +! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later +: inc-d ( n -- ) + current-height get + [ [ + ] change-emit-d drop ] + [ [ + ] change-d drop ] + 2bi ; + +: inc-r ( n -- ) + current-height get + [ [ + ] change-emit-r drop ] + [ [ + ] change-r drop ] + 2bi ; + +: peek-loc ( loc -- vreg ) + translate-local-loc + [ dup local-replace-set get key? [ drop ] [ local-peek-set get conjoin ] if ] + [ loc>vreg [ i ] dip [ record-copy ] [ ##copy ] [ drop ] 2tri ] + bi ; + +: replace-loc ( vreg loc -- ) + translate-local-loc + 2dup [ resolve-copy ] dip loc>vreg = [ 2drop ] [ + [ local-replace-set get conjoin ] + [ loc>vreg swap ##copy ] + bi + ] if ; + +: begin-local-analysis ( -- ) + H{ } clone copies set + H{ } clone local-peek-set set + H{ } clone local-replace-set set + current-height get 0 >>emit-d 0 >>emit-r drop + current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ; + +: end-local-analysis ( -- ) + emit-height-changes + local-peek-set get basic-block get peek-sets get set-at + local-replace-set get basic-block get replace-sets get set-at ; + +: clone-current-height ( -- ) + current-height [ clone ] change ; + +: peek-set ( bb -- assoc ) peek-sets get at ; +: replace-set ( bb -- assoc ) replace-sets get at ; diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index c8fcae87c0..f68b70467a 100755 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -1,45 +1,76 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math sequences kernel cpu.architecture -compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.hats ; +USING: math sequences kernel namespaces accessors compiler.cfg +compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats +compiler.cfg.predecessors compiler.cfg.stacks.local +compiler.cfg.stacks.height compiler.cfg.stacks.global +compiler.cfg.stacks.finalize ; IN: compiler.cfg.stacks -: ds-drop ( -- ) - -1 ##inc-d ; +: begin-stack-analysis ( -- ) + H{ } clone locs>vregs set + H{ } clone ds-heights set + H{ } clone rs-heights set + H{ } clone peek-sets set + H{ } clone replace-sets set + current-height new current-height set ; -: ds-pop ( -- vreg ) - D 0 ^^peek -1 ##inc-d ; +: end-stack-analysis ( -- ) + cfg get + compute-predecessors + compute-global-sets + finalize-stack-shuffling + drop ; -: ds-push ( vreg -- ) - 1 ##inc-d D 0 ##replace ; +: ds-drop ( -- ) -1 inc-d ; + +: ds-peek ( -- vreg ) D 0 peek-loc ; + +: ds-pop ( -- vreg ) ds-peek ds-drop ; + +: ds-push ( vreg -- ) 1 inc-d D 0 replace-loc ; : ds-load ( n -- vregs ) dup 0 = [ drop f ] - [ [ [ ^^peek ] map ] [ neg ##inc-d ] bi ] if ; + [ [ [ peek-loc ] map ] [ neg inc-d ] bi ] if ; : ds-store ( vregs -- ) [ - [ length ##inc-d ] - [ [ ##replace ] each-index ] bi + [ length inc-d ] + [ [ replace-loc ] each-index ] bi ] unless-empty ; +: rs-drop ( -- ) -1 inc-r ; + : rs-load ( n -- vregs ) dup 0 = [ drop f ] - [ [ [ ^^peek ] map ] [ neg ##inc-r ] bi ] if ; + [ [ [ peek-loc ] map ] [ neg inc-r ] bi ] if ; : rs-store ( vregs -- ) [ - [ length ##inc-r ] - [ [ ##replace ] each-index ] bi + [ length inc-r ] + [ [ replace-loc ] each-index ] bi ] unless-empty ; +: (2inputs) ( -- vreg1 vreg2 ) + D 1 peek-loc D 0 peek-loc ; + : 2inputs ( -- vreg1 vreg2 ) - D 1 ^^peek D 0 ^^peek -2 ##inc-d ; + (2inputs) -2 inc-d ; + +: (3inputs) ( -- vreg1 vreg2 vreg3 ) + D 2 peek-loc D 1 peek-loc D 0 peek-loc ; : 3inputs ( -- vreg1 vreg2 vreg3 ) - D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ; + (3inputs) -3 inc-d ; + +! adjust-d/adjust-r: these are called when other instructions which +! internally adjust the stack height are emitted, such as ##call and +! ##alien-invoke +: adjust-d ( n -- ) current-height get [ + ] change-d drop ; +: adjust-r ( n -- ) current-height get [ + ] change-r drop ; + diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index c3d3e47485..ad3ee9c57b 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -20,42 +20,6 @@ IN: compiler.cfg.utilities } cond ] [ drop f ] if ; -: set-basic-block ( basic-block -- ) - [ basic-block set ] [ instructions>> building set ] bi ; - -: begin-basic-block ( -- ) - basic-block get [ - dupd successors>> push - ] when* - set-basic-block ; - -: end-basic-block ( -- ) - building off - basic-block off ; - -: emit-trivial-block ( quot -- ) - basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless - call - ##branch begin-basic-block ; inline - -: call-height ( #call -- n ) - [ out-d>> length ] [ in-d>> length ] bi - ; - -: emit-primitive ( node -- ) - [ [ word>> ] [ call-height ] bi ##call ] emit-trivial-block ; - -: with-branch ( quot -- final-bb ) - [ - begin-basic-block - call - basic-block get dup [ ##branch ] when - ] with-scope ; inline - -: emit-conditional ( branches -- ) - end-basic-block - begin-basic-block - basic-block get '[ [ _ swap successors>> push ] when* ] each ; - PREDICATE: kill-block < basic-block instructions>> { [ length 2 = ] From 2bea1072025902d557023584189a40c2ec6549c4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Jul 2009 21:24:15 -0500 Subject: [PATCH 46/52] compiler.cfg.builder: fix stack effect declaration --- basis/compiler/cfg/builder/builder.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 7a877ad49f..4ae5cfcc57 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -195,7 +195,7 @@ M: #terminate emit-node drop ##no-tco end-basic-block ; [ return>> return-size >>return ] [ alien-parameters parameter-sizes drop >>params ] bi ; -: alien-node-height ( params -- n ) +: alien-node-height ( params -- ) [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; : emit-alien-node ( node quot -- ) From 7590ad3574e123c342ddf61bb9987f4cd580cdda Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Jul 2009 03:37:18 -0500 Subject: [PATCH 47/52] compiler.cfg: introduce less temporaries when building CFG --- .../compiler/cfg/builder/blocks/blocks.factor | 2 +- basis/compiler/cfg/builder/builder.factor | 18 ++++---- basis/compiler/cfg/hats/hats.factor | 4 +- .../cfg/intrinsics/fixnum/fixnum.factor | 4 +- basis/compiler/cfg/stacks/local/local.factor | 45 ++++++++++++------- basis/compiler/cfg/stacks/stacks.factor | 4 +- 6 files changed, 45 insertions(+), 32 deletions(-) diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor index 4f4f9ad7b3..8e96255bdd 100644 --- a/basis/compiler/cfg/builder/blocks/blocks.factor +++ b/basis/compiler/cfg/builder/blocks/blocks.factor @@ -27,7 +27,7 @@ IN: compiler.cfg.builder.blocks (begin-basic-block) ; : emit-trivial-block ( quot -- ) - building get empty? [ ##branch begin-basic-block ] unless + ##branch begin-basic-block call ##branch begin-basic-block ; inline diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 4ae5cfcc57..ed1069d043 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -72,11 +72,6 @@ GENERIC: emit-node ( node -- ) basic-block get successors>> push end-basic-block ; -: emit-trivial-block ( quot -- ) - basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless - call - ##branch begin-basic-block ; inline - : emit-call ( word height -- ) over loops get key? [ drop loops get at emit-loop-call ] @@ -109,9 +104,6 @@ M: #recursive emit-node : emit-if ( node -- ) children>> [ emit-branch ] map emit-conditional ; -: ##branch-t ( vreg -- ) - \ f tag-number cc/= ##compare-imm-branch ; - : trivial-branch? ( nodes -- value ? ) dup length 1 = [ first dup #push? [ literal>> t ] [ drop f f ] if @@ -135,15 +127,23 @@ M: #recursive emit-node : emit-trivial-not-if ( -- ) ds-pop \ f tag-number cc= ^^compare-imm ds-push ; +: emit-actual-if ( #if -- ) + ! Inputs to the final instruction need to be copied because of + ! loc>vreg sync + ds-pop ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ; + M: #if emit-node { { [ dup trivial-if? ] [ drop emit-trivial-if ] } { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] } - [ ds-pop ##branch-t emit-if ] + [ emit-actual-if ] } cond ; ! #dispatch M: #dispatch emit-node + ! Inputs to the final instruction need to be copied because of + ! loc>vreg sync. ^^offset>slot always returns a fresh vreg, + ! though. ds-pop ^^offset>slot i ##dispatch emit-if ; ! #call diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 287d0a6999..4c1999943f 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -18,7 +18,7 @@ IN: compiler.cfg.hats : ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline : ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline -: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline +: ^^copy ( src -- dst ) ^^i1 ##copy ; inline : ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline : ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline : ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline @@ -74,7 +74,7 @@ IN: compiler.cfg.hats : ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline : ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline : ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline -: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline +: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline : ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 0eeeb0b12d..d4b9db58c8 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -69,7 +69,9 @@ IN: compiler.cfg.intrinsics.fixnum [ ##call -1 adjust-d ] with-branch ; : emit-fixnum-overflow-op ( quot word -- ) - [ [ (2inputs) ] dip call ] dip + ! Inputs to the final instruction need to be copied because + ! of loc>vreg sync + [ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array emit-conditional ; inline diff --git a/basis/compiler/cfg/stacks/local/local.factor b/basis/compiler/cfg/stacks/local/local.factor index a484464a59..754789042a 100644 --- a/basis/compiler/cfg/stacks/local/local.factor +++ b/basis/compiler/cfg/stacks/local/local.factor @@ -1,9 +1,12 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel math namespaces sets make sequences -compiler.cfg compiler.cfg.hats -compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.stacks.height ; +compiler.cfg +compiler.cfg.hats +compiler.cfg.instructions +compiler.cfg.registers +compiler.cfg.stacks.height +compiler.cfg.parallel-copy ; IN: compiler.cfg.stacks.local ! Local stack analysis. We build local peek and replace sets for every basic @@ -14,24 +17,31 @@ SYMBOLS: peek-sets replace-sets ; SYMBOL: locs>vregs : loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ; +: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ; TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ; -SYMBOLS: copies local-peek-set local-replace-set ; - -: record-copy ( dst src -- ) swap copies get set-at ; -: resolve-copy ( vreg -- vreg' ) copies get ?at drop ; +SYMBOLS: local-peek-set local-replace-set replace-mapping ; GENERIC: translate-local-loc ( loc -- loc' ) M: ds-loc translate-local-loc n>> current-height get d>> - ; M: rs-loc translate-local-loc n>> current-height get r>> - ; +: emit-stack-changes ( -- ) + replace-mapping get dup assoc-empty? [ drop ] [ + [ [ loc>vreg ] dip ] assoc-map parallel-copy + ] if ; + : emit-height-changes ( -- ) - ! Insert height changes prior to the last instruction - building get pop current-height get [ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ] - [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi + [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi ; + +: emit-changes ( -- ) + ! Insert height and stack changes prior to the last instruction + building get pop + emit-stack-changes + emit-height-changes , ; ! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later @@ -49,27 +59,28 @@ M: rs-loc translate-local-loc n>> current-height get r>> - ; : peek-loc ( loc -- vreg ) translate-local-loc - [ dup local-replace-set get key? [ drop ] [ local-peek-set get conjoin ] if ] - [ loc>vreg [ i ] dip [ record-copy ] [ ##copy ] [ drop ] 2tri ] - bi ; + dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless + dup replace-mapping get at [ ] [ loc>vreg ] ?if ; : replace-loc ( vreg loc -- ) translate-local-loc - 2dup [ resolve-copy ] dip loc>vreg = [ 2drop ] [ + 2dup loc>vreg = + [ nip replace-mapping get delete-at ] + [ [ local-replace-set get conjoin ] - [ loc>vreg swap ##copy ] + [ replace-mapping get set-at ] bi ] if ; : begin-local-analysis ( -- ) - H{ } clone copies set H{ } clone local-peek-set set H{ } clone local-replace-set set + H{ } clone replace-mapping set current-height get 0 >>emit-d 0 >>emit-r drop current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ; : end-local-analysis ( -- ) - emit-height-changes + emit-changes local-peek-set get basic-block get peek-sets get set-at local-replace-set get basic-block get replace-sets get set-at ; diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index f68b70467a..2683222fb8 100755 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math sequences kernel namespaces accessors compiler.cfg +USING: math sequences kernel namespaces accessors biassocs compiler.cfg compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats compiler.cfg.predecessors compiler.cfg.stacks.local compiler.cfg.stacks.height compiler.cfg.stacks.global @@ -8,7 +8,7 @@ compiler.cfg.stacks.finalize ; IN: compiler.cfg.stacks : begin-stack-analysis ( -- ) - H{ } clone locs>vregs set + locs>vregs set H{ } clone ds-heights set H{ } clone rs-heights set H{ } clone peek-sets set From de73534424d6ef19254e53ab1388c28985b090e6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Jul 2009 05:29:28 -0500 Subject: [PATCH 48/52] compiler.cfg.write-barrier: simplify a little bit. It doesn't need to do copy propagation, since its a separate pass now --- .../cfg/write-barrier/write-barrier.factor | 31 +++++++------------ 1 file changed, 12 insertions(+), 19 deletions(-) diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index bcec542501..2f32a4ca81 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors namespaces assocs sets sequences locals -compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop -compiler.cfg.rpo ; +USING: kernel accessors namespaces assocs sets sequences +compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ; IN: compiler.cfg.write-barrier ! Eliminate redundant write barrier hits. @@ -14,33 +13,27 @@ SYMBOL: safe ! Objects which have been mutated SYMBOL: mutated -GENERIC: eliminate-write-barrier ( insn -- insn' ) +GENERIC: eliminate-write-barrier ( insn -- ? ) M: ##allot eliminate-write-barrier - dup dst>> safe get conjoin ; + dst>> safe get conjoin t ; M: ##write-barrier eliminate-write-barrier - dup src>> resolve dup - [ safe get key? not ] - [ mutated get key? ] bi and - [ safe get conjoin ] [ 2drop f ] if ; - -M: ##copy eliminate-write-barrier - dup record-copy ; + src>> dup [ safe get key? not ] [ mutated get key? ] bi and + [ safe get conjoin t ] [ drop f ] if ; M: ##set-slot eliminate-write-barrier - dup obj>> resolve mutated get conjoin ; + obj>> mutated get conjoin t ; M: ##set-slot-imm eliminate-write-barrier - dup obj>> resolve mutated get conjoin ; + obj>> mutated get conjoin t ; -M: insn eliminate-write-barrier ; +M: insn eliminate-write-barrier drop t ; -: write-barriers-step ( insns -- insns' ) +: write-barriers-step ( bb -- ) H{ } clone safe set H{ } clone mutated set - H{ } clone copies set - [ eliminate-write-barrier ] map sift ; + instructions>> [ eliminate-write-barrier ] filter-here ; : eliminate-write-barriers ( cfg -- cfg' ) - [ write-barriers-step ] local-optimization ; + dup [ write-barriers-step ] each-basic-block ; From e0f6d89ff1f331dbd05fc6b6947394f3f811719c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Jul 2009 05:30:30 -0500 Subject: [PATCH 49/52] compiler.cfg.value-numbering: insert ##copy instructions for instructions whose expressions simplify. While subsequent usages are replaced with the instruction computing the simplified vreg locally, global usages may exist of the original instruction. In this case, the ##copy is not dead --- .../value-numbering/rewrite/rewrite.factor | 52 +++++++++---------- .../value-numbering/simplify/simplify.factor | 16 +++--- .../value-numbering/value-numbering.factor | 31 ++++++----- 3 files changed, 50 insertions(+), 49 deletions(-) diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index fcd1b1c9ac..4b8ee2a1ae 100755 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -20,13 +20,9 @@ IN: compiler.cfg.value-numbering.rewrite ! Outputs f to mean no change -GENERIC: rewrite* ( insn -- insn/f ) +GENERIC: rewrite ( insn -- insn/f ) -: rewrite ( insn -- insn' ) - dup [ number-values ] [ rewrite* ] bi - [ rewrite ] [ ] ?if ; - -M: insn rewrite* drop f ; +M: insn rewrite drop f ; : ##branch-t? ( insn -- ? ) dup ##compare-imm-branch? [ @@ -123,7 +119,7 @@ ERROR: bad-comparison ; : fold-compare-imm-branch ( insn -- insn/f ) (fold-compare-imm) fold-branch ; -M: ##compare-imm-branch rewrite* +M: ##compare-imm-branch rewrite { { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] } { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] } @@ -154,7 +150,7 @@ M: ##compare-imm-branch rewrite* : rewrite-self-compare-branch ( insn -- insn' ) (rewrite-self-compare) fold-branch ; -M: ##compare-branch rewrite* +M: ##compare-branch rewrite { { [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] } { [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] } @@ -185,7 +181,7 @@ M: ##compare-branch rewrite* : rewrite-self-compare ( insn -- insn' ) dup (rewrite-self-compare) >boolean-insn ; -M: ##compare rewrite* +M: ##compare rewrite { { [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] } { [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] } @@ -196,7 +192,7 @@ M: ##compare rewrite* : fold-compare-imm ( insn -- insn' ) dup (fold-compare-imm) >boolean-insn ; -M: ##compare-imm rewrite* +M: ##compare-imm rewrite { { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] } { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] } @@ -238,7 +234,7 @@ M: ##shl-imm constant-fold* drop shift ; ] dip over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline -M: ##add-imm rewrite* +M: ##add-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup reassociate? ] [ \ ##add-imm reassociate ] } @@ -249,7 +245,7 @@ M: ##add-imm rewrite* [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough? [ \ ##add-imm new-insn ] [ 3drop f ] if ; -M: ##sub-imm rewrite* +M: ##sub-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } [ sub-imm>add-imm ] @@ -261,7 +257,7 @@ M: ##sub-imm rewrite* : strength-reduce-mul? ( insn -- ? ) src2>> power-of-2? ; -M: ##mul-imm rewrite* +M: ##mul-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup strength-reduce-mul? ] [ strength-reduce-mul ] } @@ -269,40 +265,40 @@ M: ##mul-imm rewrite* [ drop f ] } cond ; -M: ##and-imm rewrite* +M: ##and-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup reassociate? ] [ \ ##and-imm reassociate ] } [ drop f ] } cond ; -M: ##or-imm rewrite* +M: ##or-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup reassociate? ] [ \ ##or-imm reassociate ] } [ drop f ] } cond ; -M: ##xor-imm rewrite* +M: ##xor-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup reassociate? ] [ \ ##xor-imm reassociate ] } [ drop f ] } cond ; -M: ##shl-imm rewrite* +M: ##shl-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } [ drop f ] } cond ; -M: ##shr-imm rewrite* +M: ##shr-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } [ drop f ] } cond ; -M: ##sar-imm rewrite* +M: ##sar-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } [ drop f ] @@ -327,7 +323,7 @@ M: ##sar-imm rewrite* [ 2drop f ] } cond ; inline -M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ; +M: ##add rewrite \ ##add-imm rewrite-arithmetic-commutative ; : subtraction-identity? ( insn -- ? ) [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ; @@ -335,22 +331,22 @@ M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ; : rewrite-subtraction-identity ( insn -- insn' ) dst>> 0 \ ##load-immediate new-insn ; -M: ##sub rewrite* +M: ##sub rewrite { { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] } [ \ ##sub-imm rewrite-arithmetic ] } cond ; -M: ##mul rewrite* \ ##mul-imm rewrite-arithmetic-commutative ; +M: ##mul rewrite \ ##mul-imm rewrite-arithmetic-commutative ; -M: ##and rewrite* \ ##and-imm rewrite-arithmetic-commutative ; +M: ##and rewrite \ ##and-imm rewrite-arithmetic-commutative ; -M: ##or rewrite* \ ##or-imm rewrite-arithmetic-commutative ; +M: ##or rewrite \ ##or-imm rewrite-arithmetic-commutative ; -M: ##xor rewrite* \ ##xor-imm rewrite-arithmetic-commutative ; +M: ##xor rewrite \ ##xor-imm rewrite-arithmetic-commutative ; -M: ##shl rewrite* \ ##shl-imm rewrite-arithmetic ; +M: ##shl rewrite \ ##shl-imm rewrite-arithmetic ; -M: ##shr rewrite* \ ##shr-imm rewrite-arithmetic ; +M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ; -M: ##sar rewrite* \ ##sar-imm rewrite-arithmetic ; +M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ; diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor index 5934643acc..3e1f6e393b 100644 --- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor +++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor @@ -120,14 +120,12 @@ M: binary-expr simplify* M: expr simplify* drop f ; -: simplify ( expr -- vn ) +: simplify ( expr -- simplified? vn ) dup simplify* { - { [ dup not ] [ drop expr>vn ] } - { [ dup expr? ] [ expr>vn nip ] } - { [ dup integer? ] [ nip ] } - } cond ; + { [ dup not ] [ drop expr>vn f ] } + { [ dup expr? ] [ expr>vn nip t ] } + { [ dup integer? ] [ nip t ] } + } cond swap ; -GENERIC: number-values ( insn -- ) - -M: ##flushable number-values [ >expr simplify ] [ dst>> ] bi set-vn ; -M: insn number-values drop ; +: number-values ( insn -- simplified? ) + [ >expr simplify ] [ dst>> set-vn ] bi ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index 0c9616b4e5..0688d81109 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs biassocs classes kernel math accessors -sorting sets sequences fry +USING: namespaces assocs kernel accessors +sorting sets sequences compiler.cfg compiler.cfg.rpo -compiler.cfg.renaming +compiler.cfg.instructions compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.expressions compiler.cfg.value-numbering.simplify @@ -12,20 +12,27 @@ compiler.cfg.value-numbering.rewrite ; IN: compiler.cfg.value-numbering ! Local value numbering. Predecessors must be recomputed after this -: vreg>vreg-mapping ( -- assoc ) - vregs>vns get [ keys ] keep - '[ dup _ [ at ] [ value-at ] bi ] H{ } map>assoc ; +: >copy ( insn -- ##copy ) + dst>> dup vreg>vn vn>vreg \ ##copy new-insn ; -: rename-uses ( insns -- ) - vreg>vreg-mapping renamings [ - [ rename-insn-uses ] each - ] with-variable ; +: rewrite-loop ( insn -- insn' ) + dup rewrite [ rewrite-loop ] [ ] ?if ; + +GENERIC: process-instruction ( insn -- insn' ) + +M: ##flushable process-instruction + dup rewrite + [ process-instruction ] + [ dup number-values [ >copy ] when ] ?if ; + +M: insn process-instruction + dup rewrite + [ process-instruction ] [ ] ?if ; : value-numbering-step ( insns -- insns' ) init-value-graph init-expressions - [ rewrite ] map - dup rename-uses ; + [ process-instruction ] map ; : value-numbering ( cfg -- cfg' ) [ value-numbering-step ] local-optimization cfg-changed ; From 7068de6cd30322fd77d4e39454c30c69b2421cef Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Jul 2009 05:30:46 -0500 Subject: [PATCH 50/52] compiler.cfg.copy-prop: Global copy propagation --- basis/compiler/cfg/copy-prop/copy-prop.factor | 28 +++++++++++++++++-- basis/compiler/cfg/optimizer/optimizer.factor | 8 ++++-- basis/compiler/cfg/renaming/renaming.factor | 4 +++ 3 files changed, 35 insertions(+), 5 deletions(-) diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor index d526ea9c1d..b13aa5d75b 100644 --- a/basis/compiler/cfg/copy-prop/copy-prop.factor +++ b/basis/compiler/cfg/copy-prop/copy-prop.factor @@ -1,8 +1,10 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces assocs accessors ; +USING: kernel namespaces assocs accessors sequences +compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.instructions ; IN: compiler.cfg.copy-prop +! The first three definitions are also used in compiler.cfg.alias-analysis. SYMBOL: copies : resolve ( vreg -- vreg ) @@ -10,3 +12,25 @@ SYMBOL: copies : record-copy ( insn -- ) [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline + +: collect-copies ( cfg -- ) + H{ } clone copies set + [ + instructions>> + [ dup ##copy? [ record-copy ] [ drop ] if ] each + ] each-basic-block ; + +: rename-copies ( cfg -- ) + copies get dup assoc-empty? [ 2drop ] [ + renamings set + [ + instructions>> + [ dup ##copy? [ drop f ] [ rename-insn-uses t ] if ] filter-here + ] each-basic-block + ] if ; + +: copy-propagation ( cfg -- cfg' ) + [ collect-copies ] + [ rename-copies ] + [ ] + tri ; diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index e4ad290097..ede2a9382c 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -2,18 +2,19 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors combinators namespaces compiler.cfg.tco -compiler.cfg.predecessors compiler.cfg.useless-conditionals -compiler.cfg.ssa compiler.cfg.branch-splitting compiler.cfg.block-joining +compiler.cfg.ssa compiler.cfg.alias-analysis compiler.cfg.value-numbering +compiler.cfg.copy-prop compiler.cfg.dce compiler.cfg.write-barrier -compiler.cfg.rpo compiler.cfg.phi-elimination compiler.cfg.empty-blocks +compiler.cfg.predecessors +compiler.cfg.rpo compiler.cfg.checker ; IN: compiler.cfg.optimizer @@ -38,6 +39,7 @@ SYMBOL: check-optimizer? alias-analysis value-numbering compute-predecessors + copy-propagation eliminate-dead-code eliminate-write-barriers eliminate-phis diff --git a/basis/compiler/cfg/renaming/renaming.factor b/basis/compiler/cfg/renaming/renaming.factor index a2204fb36e..eb8538256a 100644 --- a/basis/compiler/cfg/renaming/renaming.factor +++ b/basis/compiler/cfg/renaming/renaming.factor @@ -102,6 +102,10 @@ M: ##fixnum-overflow rename-insn-uses [ rename-value ] change-src2 drop ; +M: ##phi rename-insn-uses + [ [ rename-value ] assoc-map ] change-inputs + drop ; + M: insn rename-insn-uses drop ; : fresh-vreg ( vreg -- vreg' ) From 13c3fdcb5c0bb663246e17ac18a62f279d4b624d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Jul 2009 06:08:07 -0500 Subject: [PATCH 51/52] compiler.cfg: Fixing test failures --- .../value-numbering/simplify/simplify.factor | 14 +++--- .../value-numbering-tests.factor | 47 +++++++------------ .../value-numbering/value-numbering.factor | 7 +-- .../write-barrier/write-barrier-tests.factor | 40 +++++++--------- 4 files changed, 45 insertions(+), 63 deletions(-) diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor index 3e1f6e393b..6bd84021b3 100644 --- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor +++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor @@ -120,12 +120,12 @@ M: binary-expr simplify* M: expr simplify* drop f ; -: simplify ( expr -- simplified? vn ) +: simplify ( expr -- vn ) dup simplify* { - { [ dup not ] [ drop expr>vn f ] } - { [ dup expr? ] [ expr>vn nip t ] } - { [ dup integer? ] [ nip t ] } - } cond swap ; + { [ dup not ] [ drop expr>vn ] } + { [ dup expr? ] [ expr>vn nip ] } + { [ dup integer? ] [ nip ] } + } cond ; -: number-values ( insn -- simplified? ) - [ >expr simplify ] [ dst>> set-vn ] bi ; +: number-values ( insn -- ) + [ >expr simplify ] [ dst>> ] bi set-vn ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 9063947ae1..60d06fcde4 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -35,9 +35,9 @@ compiler.cfg assocs vectors arrays layouts namespaces ; [ { T{ ##load-reference f V int-regs 0 0.0 } - T{ ##load-reference f V int-regs 1 0.0 } + T{ ##copy f V int-regs 1 V int-regs 0 } T{ ##replace f V int-regs 0 D 0 } - T{ ##replace f V int-regs 0 D 1 } + T{ ##replace f V int-regs 1 D 1 } } ] [ { @@ -51,9 +51,9 @@ compiler.cfg assocs vectors arrays layouts namespaces ; [ { T{ ##load-reference f V int-regs 0 t } - T{ ##load-reference f V int-regs 1 t } + T{ ##copy f V int-regs 1 V int-regs 0 } T{ ##replace f V int-regs 0 D 0 } - T{ ##replace f V int-regs 0 D 1 } + T{ ##replace f V int-regs 1 D 1 } } ] [ { @@ -64,29 +64,14 @@ compiler.cfg assocs vectors arrays layouts namespaces ; } value-numbering-step ] unit-test -! Copy propagation -[ - { - T{ ##peek f V int-regs 45 D 1 } - T{ ##copy f V int-regs 48 V int-regs 45 } - T{ ##compare-imm-branch f V int-regs 45 7 cc/= } - } -] [ - { - T{ ##peek f V int-regs 45 D 1 } - T{ ##copy f V int-regs 48 V int-regs 45 } - T{ ##compare-imm-branch f V int-regs 48 7 cc/= } - } value-numbering-step -] unit-test - ! Compare propagation [ { T{ ##load-reference f V int-regs 1 + } T{ ##peek f V int-regs 2 D 0 } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } - T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> } - T{ ##replace f V int-regs 4 D 0 } + T{ ##copy f V int-regs 6 V int-regs 4 } + T{ ##replace f V int-regs 6 D 0 } } ] [ { @@ -612,8 +597,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##peek f V int-regs 1 D 1 } T{ ##load-immediate f V int-regs 2 0 } - T{ ##add-imm f V int-regs 3 V int-regs 0 0 } - T{ ##replace f V int-regs 0 D 0 } + T{ ##copy f V int-regs 3 V int-regs 0 } + T{ ##replace f V int-regs 3 D 0 } } ] [ { @@ -630,8 +615,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##peek f V int-regs 1 D 1 } T{ ##load-immediate f V int-regs 2 0 } - T{ ##add-imm f V int-regs 3 V int-regs 0 0 } - T{ ##replace f V int-regs 0 D 0 } + T{ ##copy f V int-regs 3 V int-regs 0 } + T{ ##replace f V int-regs 3 D 0 } } ] [ { @@ -648,8 +633,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##peek f V int-regs 1 D 1 } T{ ##load-immediate f V int-regs 2 0 } - T{ ##or-imm f V int-regs 3 V int-regs 0 0 } - T{ ##replace f V int-regs 0 D 0 } + T{ ##copy f V int-regs 3 V int-regs 0 } + T{ ##replace f V int-regs 3 D 0 } } ] [ { @@ -666,8 +651,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##peek f V int-regs 1 D 1 } T{ ##load-immediate f V int-regs 2 0 } - T{ ##xor-imm f V int-regs 3 V int-regs 0 0 } - T{ ##replace f V int-regs 0 D 0 } + T{ ##copy f V int-regs 3 V int-regs 0 } + T{ ##replace f V int-regs 3 D 0 } } ] [ { @@ -683,8 +668,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ; { T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 1 } - T{ ##shl-imm f V int-regs 2 V int-regs 0 0 } - T{ ##replace f V int-regs 0 D 0 } + T{ ##copy f V int-regs 2 V int-regs 0 } + T{ ##replace f V int-regs 2 D 0 } } ] [ { diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index 0688d81109..a249f71c02 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -12,8 +12,9 @@ compiler.cfg.value-numbering.rewrite ; IN: compiler.cfg.value-numbering ! Local value numbering. Predecessors must be recomputed after this -: >copy ( insn -- ##copy ) - dst>> dup vreg>vn vn>vreg \ ##copy new-insn ; +: >copy ( insn -- insn/##copy ) + dup dst>> dup vreg>vn vn>vreg + 2dup eq? [ 2drop ] [ \ ##copy new-insn nip ] if ; : rewrite-loop ( insn -- insn' ) dup rewrite [ rewrite-loop ] [ ] ?if ; @@ -23,7 +24,7 @@ GENERIC: process-instruction ( insn -- insn' ) M: ##flushable process-instruction dup rewrite [ process-instruction ] - [ dup number-values [ >copy ] when ] ?if ; + [ dup number-values >copy ] ?if ; M: insn process-instruction dup rewrite diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor index c1a667c004..14197bc3f7 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor @@ -1,42 +1,43 @@ USING: compiler.cfg.write-barrier compiler.cfg.instructions compiler.cfg.registers compiler.cfg.debugger cpu.architecture -arrays tools.test vectors compiler.cfg kernel accessors ; +arrays tools.test vectors compiler.cfg kernel accessors +compiler.cfg.utilities ; IN: compiler.cfg.write-barrier.tests : test-write-barrier ( insns -- insns ) - write-barriers-step ; + dup write-barriers-step instructions>> ; [ - { + V{ T{ ##peek f V int-regs 4 D 0 f } - T{ ##copy f V int-regs 6 V int-regs 4 f } T{ ##allot f V int-regs 7 24 array V int-regs 8 f } T{ ##load-immediate f V int-regs 9 8 f } T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f } - T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 f } + T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 f } T{ ##replace f V int-regs 7 D 0 f } + T{ ##branch } } ] [ { T{ ##peek f V int-regs 4 D 0 } - T{ ##copy f V int-regs 6 V int-regs 4 } T{ ##allot f V int-regs 7 24 array V int-regs 8 } T{ ##load-immediate f V int-regs 9 8 } T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 } T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 } - T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 } + T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 } T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 } T{ ##replace f V int-regs 7 D 0 } } test-write-barrier ] unit-test [ - { + V{ T{ ##load-immediate f V int-regs 4 24 } T{ ##peek f V int-regs 5 D -1 } T{ ##peek f V int-regs 6 D -2 } T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 } T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 } + T{ ##branch } } ] [ { @@ -49,28 +50,23 @@ IN: compiler.cfg.write-barrier.tests ] unit-test [ - { + V{ T{ ##peek f V int-regs 19 D -3 } T{ ##peek f V int-regs 22 D -2 } - T{ ##copy f V int-regs 23 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 } - T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 } - T{ ##copy f V int-regs 26 V int-regs 19 } + T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 } + T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 } T{ ##peek f V int-regs 28 D -1 } - T{ ##copy f V int-regs 29 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 } + T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 } + T{ ##branch } } ] [ { T{ ##peek f V int-regs 19 D -3 } T{ ##peek f V int-regs 22 D -2 } - T{ ##copy f V int-regs 23 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 } - T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 } - T{ ##copy f V int-regs 26 V int-regs 19 } + T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 } + T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 } T{ ##peek f V int-regs 28 D -1 } - T{ ##copy f V int-regs 29 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 } - T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 } + T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 } + T{ ##write-barrier f V int-regs 19 V int-regs 30 V int-regs 3 } } test-write-barrier ] unit-test From 4624af75f4047644423049ec60e5d02f0d438114 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Jul 2009 16:45:31 -0500 Subject: [PATCH 52/52] compiler.cfg.phi-elimination: move some utilities from compiler.cfg.utilities here since that's the only place they get used --- .../cfg/phi-elimination/phi-elimination.factor | 14 ++++++++++++++ basis/compiler/cfg/utilities/utilities.factor | 14 -------------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination.factor b/basis/compiler/cfg/phi-elimination/phi-elimination.factor index 7e73f0b854..38e82176ca 100644 --- a/basis/compiler/cfg/phi-elimination/phi-elimination.factor +++ b/basis/compiler/cfg/phi-elimination/phi-elimination.factor @@ -6,6 +6,20 @@ compiler.cfg.utilities compiler.cfg.hats make locals ; IN: compiler.cfg.phi-elimination +! assoc mapping predecessors to sequences +SYMBOL: added-instructions + +: add-instructions ( predecessor quot -- ) + [ + added-instructions get + [ drop V{ } clone ] cache + building + ] dip with-variable ; inline + +: insert-basic-blocks ( bb -- ) + [ added-instructions get ] dip + '[ [ _ ] dip insert-basic-block ] assoc-each ; + : insert-copy ( predecessor input output -- ) '[ _ _ swap ##copy ] add-instructions ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index ad3ee9c57b..4b0468b911 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -48,16 +48,6 @@ SYMBOL: visited : skip-empty-blocks ( bb -- bb' ) H{ } clone visited [ (skip-empty-blocks) ] with-variable ; -! assoc mapping predecessors to sequences -SYMBOL: added-instructions - -: add-instructions ( predecessor quot -- ) - [ - added-instructions get - [ drop V{ } clone ] cache - building - ] dip with-variable ; inline - :: insert-basic-block ( from to bb -- ) bb from 1vector >>predecessors drop bb to 1vector >>successors drop @@ -69,7 +59,3 @@ SYMBOL: added-instructions swap >vector \ ##branch new-insn over push >>instructions ; - -: insert-basic-blocks ( bb -- ) - [ added-instructions get ] dip - '[ [ _ ] dip insert-basic-block ] assoc-each ;