From 713e71fd3c0662106cfb0d55bcc2e1fbf9f54a91 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Fri, 3 Jul 2009 23:21:21 +1200 Subject: [PATCH 01/28] alien.inline: added define-c-function' and refactored existing words --- basis/alien/inline/inline.factor | 63 ++++++++++++++++++++++---------- 1 file changed, 44 insertions(+), 19 deletions(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 8e58071427..0ca67249da 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.inline.compiler alien.libraries -alien.parser arrays fry generalizations io.files io.files.info -io.files.temp kernel lexer math.order multiline namespaces -sequences system vocabs.loader vocabs.parser words ; +alien.parser arrays assocs effects fry generalizations grouping +io.files io.files.info io.files.temp kernel lexer math +math.order math.ranges multiline namespaces sequences splitting +strings system vocabs.loader vocabs.parser words ; IN: alien.inline params-return ( types effect -- params return ) + [ nip out>> first ] [ in>> zip ] 2bi ; + +: arg-list ( types -- params ) + CHAR: a swap length CHAR: a + [a,b] + [ 1string ] map ; + +: factorize-type ( str -- str' ) + "const-" ?head drop ; + +: cify-type ( str -- str' ) + { { CHAR: ~ CHAR: space } } substitute ; + +: factor-function ( function types effect -- ) + [ c-library get ] 3dip [ [ factorize-type ] map ] dip + types-effect>params-return factorize-type -roll make-function define-declared ; -: c-function-string ( return library function params -- str ) - [ nip ] dip - " " join "(" prepend ")" append 3array " " join +: prototype-string ( function types effect -- str ) + [ [ cify-type ] map ] dip + types-effect>params-return cify-type -rot + 2 group [ " " join "," append ] map " " join + "(" prepend ")" append 3array " " join library-is-c++ get [ "extern \"C\" " prepend ] when ; +: prototype-string' ( function types return -- str ) + [ dup arg-list ] prototype-string ; + +: append-function-body ( prototype-str -- str ) + " {\n" append parse-here append "\n}\n" append ; + + : library-path ( -- str ) "lib" c-library get library-suffix 3array concat temp-file ; @@ -53,10 +75,14 @@ PRIVATE> compile-library? [ compile-library ] when c-library get library-path "cdecl" add-library ; -: define-c-function ( return library function params -- ) - [ factor-function ] 4 nkeep c-function-string - " {\n" append parse-here append "\n}\n" append - c-strings get push ; +: define-c-function ( function types effect -- ) + [ factor-function ] 3keep prototype-string + append-function-body c-strings get push ; + +: define-c-function' ( function effect -- ) + [ in>> ] keep [ factor-function ] 3keep + out>> prototype-string' + append-function-body c-strings get push ; : define-c-link ( str -- ) "-l" prepend compiler-args get push ; @@ -82,7 +108,6 @@ SYNTAX: C-LINK/FRAMEWORK: scan define-c-link/framework ; SYNTAX: C-INCLUDE: scan define-c-include ; -SYNTAX: C-FUNCTION: - return-library-function-params define-c-function ; +SYNTAX: C-FUNCTION: function-types-effect define-c-function ; SYNTAX: ;C-LIBRARY compile-c-library ; From 8f8aa3051c02d30693ed81006941d132387226fe Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sat, 4 Jul 2009 11:28:31 +1200 Subject: [PATCH 02/28] alien.inline: factorize-type covers unsigned and long --- basis/alien/inline/inline.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 0ca67249da..ba540246b1 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -25,7 +25,9 @@ SYMBOL: c-strings [ 1string ] map ; : factorize-type ( str -- str' ) - "const-" ?head drop ; + "const-" ?head drop + "unsigned-" ?head [ "u" prepend ] when + "long-" ?head [ "long" prepend ] when ; : cify-type ( str -- str' ) { { CHAR: ~ CHAR: space } } substitute ; From f7ddd899c3e0fdadbe2701d8e8e668f11037cd5c Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sun, 5 Jul 2009 21:37:52 +1200 Subject: [PATCH 03/28] alien.inline: function-types-effect: fixed incorrect stack order --- basis/alien/inline/inline.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index ba540246b1..f9d7f06d88 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -15,7 +15,7 @@ SYMBOL: c-strings : function-types-effect ( -- function types effect ) scan scan swap ")" parse-tokens - [ "(" subseq? not ] filter parse-arglist ; + [ "(" subseq? not ] filter swap parse-arglist ; : types-effect>params-return ( types effect -- params return ) [ nip out>> first ] [ in>> zip ] 2bi ; From d2f6f99954c8434441aee0bc229cbd69c6b6b470 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sun, 5 Jul 2009 21:40:08 +1200 Subject: [PATCH 04/28] alien.inline: types->effect>params-return: fix for stack order and void return type --- basis/alien/inline/inline.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index f9d7f06d88..2b1e9dd186 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -18,7 +18,9 @@ SYMBOL: c-strings [ "(" subseq? not ] filter swap parse-arglist ; : types-effect>params-return ( types effect -- params return ) - [ nip out>> first ] [ in>> zip ] 2bi ; + [ in>> zip ] + [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ] + 2bi ; : arg-list ( types -- params ) CHAR: a swap length CHAR: a + [a,b] From 1a0a34fbfcb53f6ef0c1228a70d8b9b125036036 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sun, 5 Jul 2009 21:41:21 +1200 Subject: [PATCH 05/28] alien.inline: cify-type: fixed incorrect substitution --- basis/alien/inline/inline.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 2b1e9dd186..2500021247 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -32,7 +32,7 @@ SYMBOL: c-strings "long-" ?head [ "long" prepend ] when ; : cify-type ( str -- str' ) - { { CHAR: ~ CHAR: space } } substitute ; + { { CHAR: - CHAR: space } } substitute ; : factor-function ( function types effect -- ) [ c-library get ] 3dip [ [ factorize-type ] map ] dip From dd45949c508cacf527a22934d7dfdcfe21f3d507 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sun, 5 Jul 2009 21:42:35 +1200 Subject: [PATCH 06/28] alien.inline: prototype-string: fixed params --- basis/alien/inline/inline.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 2500021247..b71341ab6d 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -42,7 +42,7 @@ SYMBOL: c-strings : prototype-string ( function types effect -- str ) [ [ cify-type ] map ] dip types-effect>params-return cify-type -rot - 2 group [ " " join "," append ] map " " join + [ " " join ] map ", " join "(" prepend ")" append 3array " " join library-is-c++ get [ "extern \"C\" " prepend ] when ; From b2125884174c5b4ed2d462564adfe78da0c0f2d4 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sun, 5 Jul 2009 21:49:31 +1200 Subject: [PATCH 07/28] alien.inline: refactoring --- basis/alien/inline/inline.factor | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index b71341ab6d..29cc35fe27 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -34,10 +34,10 @@ SYMBOL: c-strings : cify-type ( str -- str' ) { { CHAR: - CHAR: space } } substitute ; -: factor-function ( function types effect -- ) +: factor-function ( function types effect -- word quot effect ) [ c-library get ] 3dip [ [ factorize-type ] map ] dip types-effect>params-return factorize-type -roll - make-function define-declared ; + concat make-function ; : prototype-string ( function types effect -- str ) [ [ cify-type ] map ] dip @@ -79,14 +79,12 @@ PRIVATE> compile-library? [ compile-library ] when c-library get library-path "cdecl" add-library ; -: define-c-function ( function types effect -- ) - [ factor-function ] 3keep prototype-string - append-function-body c-strings get push ; +: define-c-function ( function types effect -- prototype ) + [ factor-function define-declared ] 3keep prototype-string ; -: define-c-function' ( function effect -- ) - [ in>> ] keep [ factor-function ] 3keep - out>> prototype-string' - append-function-body c-strings get push ; +: define-c-function' ( function effect -- prototype ) + [ in>> ] keep [ factor-function define-declared ] 3keep + out>> prototype-string' ; : define-c-link ( str -- ) "-l" prepend compiler-args get push ; @@ -112,6 +110,8 @@ SYNTAX: C-LINK/FRAMEWORK: scan define-c-link/framework ; SYNTAX: C-INCLUDE: scan define-c-include ; -SYNTAX: C-FUNCTION: function-types-effect define-c-function ; +SYNTAX: C-FUNCTION: + function-types-effect define-c-function + append-function-body c-strings get push ; SYNTAX: ;C-LIBRARY compile-c-library ; From 3cd4bd81068c08648f2a5f3bde6b4935e660c552 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sun, 5 Jul 2009 21:55:11 +1200 Subject: [PATCH 08/28] alien.inline: added annotate-effect word --- basis/alien/inline/inline.factor | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 29cc35fe27..7ae530a0a0 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -13,6 +13,14 @@ SYMBOL: library-is-c++ SYMBOL: compiler-args SYMBOL: c-strings +: annotate-effect ( types effect -- types effect' ) + [ in>> ] [ out>> ] bi [ + zip + [ over pointer-to-primitive? [ ">" prepend ] when ] + assoc-map unzip + ] dip ; + + : function-types-effect ( -- function types effect ) scan scan swap ")" parse-tokens [ "(" subseq? not ] filter swap parse-arglist ; @@ -35,7 +43,8 @@ SYMBOL: c-strings { { CHAR: - CHAR: space } } substitute ; : factor-function ( function types effect -- word quot effect ) - [ c-library get ] 3dip [ [ factorize-type ] map ] dip + annotate-effect [ c-library get ] 3dip + [ [ factorize-type ] map ] dip types-effect>params-return factorize-type -roll concat make-function ; From dbe19d8173f8a8be83dc7dda3e2d38d0ee8a6d03 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Mon, 6 Jul 2009 11:06:44 +1200 Subject: [PATCH 09/28] alien.inline: reverted refactoring --- basis/alien/inline/inline.factor | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 7ae530a0a0..9a9f2eb683 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -88,12 +88,14 @@ PRIVATE> compile-library? [ compile-library ] when c-library get library-path "cdecl" add-library ; -: define-c-function ( function types effect -- prototype ) - [ factor-function define-declared ] 3keep prototype-string ; +: define-c-function ( function types effect -- ) + [ factor-function define-declared ] 3keep prototype-string + append-function-body c-strings get push ; -: define-c-function' ( function effect -- prototype ) +: define-c-function' ( function effect -- ) [ in>> ] keep [ factor-function define-declared ] 3keep - out>> prototype-string' ; + out>> prototype-string' + append-function-body c-strings get push ; : define-c-link ( str -- ) "-l" prepend compiler-args get push ; @@ -120,7 +122,6 @@ SYNTAX: C-LINK/FRAMEWORK: scan define-c-link/framework ; SYNTAX: C-INCLUDE: scan define-c-include ; SYNTAX: C-FUNCTION: - function-types-effect define-c-function - append-function-body c-strings get push ; + function-types-effect define-c-function ; SYNTAX: ;C-LIBRARY compile-c-library ; From a452f32e3a3fd05de1edc26aacf2a3b70fd9a010 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Jul 2009 21:32:23 -0500 Subject: [PATCH 10/28] compiler.cfg.linear-scan: Get cycle breaking in resolve pass to work by allocating a spare spill slot for this purpose --- .../cfg/instructions/instructions.factor | 1 - .../cfg/linear-scan/linear-scan-tests.factor | 127 +++++++++++++++++- .../linear-scan/resolve/resolve-tests.factor | 28 ++-- .../cfg/linear-scan/resolve/resolve.factor | 22 ++- 4 files changed, 158 insertions(+), 20 deletions(-) diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 1a1b2fd65c..abbb86cb16 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -261,4 +261,3 @@ INSN: _reload dst class n ; INSN: _copy dst src class ; INSN: _spill-counts counts ; -SYMBOL: spill-temp diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 63d31dfb4e..e3cd9e105f 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -206,6 +206,56 @@ check-assignment? on } 5 split-before-use [ f >>split-next ] bi@ ] unit-test +[ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 0 } + { end 4 } + { uses V{ 0 1 4 } } + { ranges V{ T{ live-range f 0 4 } } } + } + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 5 } + { end 10 } + { uses V{ 5 10 } } + { ranges V{ T{ live-range f 5 10 } } } + } +] [ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 0 } + { end 10 } + { uses V{ 0 1 10 } } + { ranges V{ T{ live-range f 0 10 } } } + } 5 split-before-use [ f >>split-next ] bi@ +] unit-test + +[ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 0 } + { end 4 } + { uses V{ 0 1 4 } } + { ranges V{ T{ live-range f 0 4 } } } + } + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 5 } + { end 10 } + { uses V{ 5 10 } } + { ranges V{ T{ live-range f 5 10 } } } + } +] [ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 0 } + { end 10 } + { uses V{ 0 1 4 5 10 } } + { ranges V{ T{ live-range f 0 10 } } } + } 5 split-before-use [ f >>split-next ] bi@ +] unit-test + [ T{ live-interval { vreg T{ vreg { reg-class int-regs } { n 1 } } } @@ -1858,6 +1908,8 @@ test-diamond [ _spill ] [ 3 get instructions>> second class ] unit-test +[ f ] [ 3 get instructions>> [ _reload? ] any? ] unit-test + [ _reload ] [ 4 get instructions>> first class ] unit-test ! Resolve pass @@ -1975,4 +2027,77 @@ V{ [ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test ! Resolve pass should insert this -[ _reload ] [ 5 get instructions>> first class ] unit-test \ No newline at end of file +[ _reload ] [ 5 get instructions>> first class ] unit-test + +! Some random bug +V{ + T{ ##peek f V int-regs 1 D 1 } + T{ ##peek f V int-regs 2 D 2 } + T{ ##replace f V int-regs 1 D 1 } + T{ ##replace f V int-regs 2 D 2 } + T{ ##peek f V int-regs 3 D 0 } + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } +} 0 test-bb + +V{ T{ ##branch } } 1 test-bb + +V{ + T{ ##peek f V int-regs 1 D 1 } + T{ ##peek f V int-regs 2 D 2 } + T{ ##replace f V int-regs 3 D 3 } + T{ ##replace f V int-regs 1 D 1 } + T{ ##replace f V int-regs 2 D 2 } + T{ ##replace f V int-regs 0 D 3 } + T{ ##branch } +} 2 test-bb + +V{ T{ ##branch } } 3 test-bb + +V{ + T{ ##return } +} 4 test-bb + +test-diamond + +[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test + +! Spilling an interval immediately after its activated; +! and the interval does not have a use at the activation point +V{ + T{ ##peek f V int-regs 1 D 1 } + T{ ##peek f V int-regs 2 D 2 } + T{ ##replace f V int-regs 1 D 1 } + T{ ##replace f V int-regs 2 D 2 } + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } +} 0 test-bb + +V{ T{ ##branch } } 1 test-bb + +V{ + T{ ##peek f V int-regs 1 D 1 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##replace f V int-regs 1 D 1 } + T{ ##peek f V int-regs 2 D 2 } + T{ ##replace f V int-regs 2 D 2 } + T{ ##branch } +} 3 test-bb + +V{ T{ ##branch } } 4 test-bb + +V{ + T{ ##replace f V int-regs 0 D 0 } + T{ ##return } +} 5 test-bb + +1 get 1vector 0 get (>>successors) +2 get 4 get V{ } 2sequence 1 get (>>successors) +5 get 1vector 4 get (>>successors) +3 get 1vector 2 get (>>successors) +5 get 1vector 3 get (>>successors) + +[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index 4c27e5c4eb..7e308cf231 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -3,6 +3,7 @@ compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.linear-scan.debugger compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.numbering +compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.resolve compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel namespaces tools.test vectors ; @@ -12,15 +13,18 @@ IN: compiler.cfg.linear-scan.resolve.tests { 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array ] unit-test +H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set +H{ } clone spill-temps set + [ { T{ _copy { dst 5 } { src 4 } { class int-regs } } - T{ _spill { src 1 } { class int-regs } { n spill-temp } } + T{ _spill { src 1 } { class int-regs } { n 10 } } T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _reload { dst 0 } { class int-regs } { n spill-temp } } - T{ _spill { src 1 } { class float-regs } { n spill-temp } } + T{ _reload { dst 0 } { class int-regs } { n 10 } } + T{ _spill { src 1 } { class float-regs } { n 20 } } T{ _copy { dst 1 } { src 0 } { class float-regs } } - T{ _reload { dst 0 } { class float-regs } { n spill-temp } } + T{ _reload { dst 0 } { class float-regs } { n 20 } } } ] [ { @@ -34,10 +38,10 @@ IN: compiler.cfg.linear-scan.resolve.tests [ { - T{ _spill { src 2 } { class int-regs } { n spill-temp } } + T{ _spill { src 2 } { class int-regs } { n 10 } } T{ _copy { dst 2 } { src 1 } { class int-regs } } T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _reload { dst 0 } { class int-regs } { n spill-temp } } + T{ _reload { dst 0 } { class int-regs } { n 10 } } } ] [ { @@ -49,10 +53,10 @@ IN: compiler.cfg.linear-scan.resolve.tests [ { - T{ _spill { src 0 } { class int-regs } { n spill-temp } } + T{ _spill { src 0 } { class int-regs } { n 10 } } T{ _copy { dst 0 } { src 2 } { class int-regs } } T{ _copy { dst 2 } { src 1 } { class int-regs } } - T{ _reload { dst 1 } { class int-regs } { n spill-temp } } + T{ _reload { dst 1 } { class int-regs } { n 10 } } } ] [ { @@ -113,10 +117,10 @@ IN: compiler.cfg.linear-scan.resolve.tests { T{ _copy { dst 1 } { src 0 } { class int-regs } } T{ _copy { dst 2 } { src 0 } { class int-regs } } - T{ _spill { src 4 } { class int-regs } { n spill-temp } } + T{ _spill { src 4 } { class int-regs } { n 10 } } T{ _copy { dst 4 } { src 0 } { class int-regs } } T{ _copy { dst 0 } { src 3 } { class int-regs } } - T{ _reload { dst 3 } { class int-regs } { n spill-temp } } + T{ _reload { dst 3 } { class int-regs } { n 10 } } } ] [ { @@ -133,10 +137,10 @@ IN: compiler.cfg.linear-scan.resolve.tests T{ _copy { dst 2 } { src 0 } { class int-regs } } T{ _copy { dst 9 } { src 1 } { class int-regs } } T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _spill { src 4 } { class int-regs } { n spill-temp } } + T{ _spill { src 4 } { class int-regs } { n 10 } } T{ _copy { dst 4 } { src 0 } { class int-regs } } T{ _copy { dst 0 } { src 3 } { class int-regs } } - T{ _reload { dst 3 } { class int-regs } { n spill-temp } } + T{ _reload { dst 3 } { class int-regs } { n 10 } } } ] [ { diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 951e727375..196d8e439f 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -3,10 +3,15 @@ USING: accessors arrays assocs classes.parser classes.tuple combinators combinators.short-circuit fry hashtables kernel locals make math math.order namespaces sequences sets words parser -compiler.cfg.instructions compiler.cfg.linear-scan.assignment -compiler.cfg.liveness ; +compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state +compiler.cfg.linear-scan.assignment compiler.cfg.liveness ; IN: compiler.cfg.linear-scan.resolve +SYMBOL: spill-temps + +: spill-temp ( reg-class -- n ) + spill-temps get [ next-spill-slot ] cache ; + << TUPLE: operation from to reg-class ; @@ -116,11 +121,15 @@ ERROR: resolve-error ; : break-cycle-n ( operations -- operations' ) split-cycle [ - [ from>> spill-temp ] - [ reg-class>> ] bi \ register->memory boa + [ from>> ] + [ reg-class>> spill-temp ] + [ reg-class>> ] + tri \ register->memory boa ] [ - [ to>> spill-temp swap ] - [ reg-class>> ] bi \ memory->register boa + [ reg-class>> spill-temp ] + [ to>> ] + [ reg-class>> ] + tri \ memory->register boa ] bi [ 1array ] bi@ surround ; : break-cycle ( operations -- operations' ) @@ -197,4 +206,5 @@ ERROR: resolve-error ; dup successors>> [ resolve-edge-data-flow ] with each ; : resolve-data-flow ( rpo -- ) + H{ } clone spill-temps set [ resolve-block-data-flow ] each ; From 5bd27a8deeadc316b494b6d376fae80395955ba9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Jul 2009 21:40:47 -0500 Subject: [PATCH 11/28] webkit-demo: update for recent stack effect change --- extra/webkit-demo/webkit-demo.factor | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/extra/webkit-demo/webkit-demo.factor b/extra/webkit-demo/webkit-demo.factor index 728764226e..e6178a55c3 100644 --- a/extra/webkit-demo/webkit-demo.factor +++ b/extra/webkit-demo/webkit-demo.factor @@ -1,12 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel -cocoa -cocoa.application -cocoa.types -cocoa.classes -cocoa.windows -core-graphics.types ; +USING: cocoa cocoa.application cocoa.types cocoa.classes cocoa.windows +core-graphics.types kernel math.bitwise ; IN: webkit-demo FRAMEWORK: /System/Library/Frameworks/WebKit.framework @@ -18,8 +13,16 @@ IMPORT: WebView WebView -> alloc rect f f -> initWithFrame:frameName:groupName: ; +: window-style ( -- n ) + { + NSClosableWindowMask + NSMiniaturizableWindowMask + NSResizableWindowMask + NSTitledWindowMask + } flags ; + : ( -- id ) - rect ; + rect window-style ; : load-url ( window url -- ) [ -> contentView ] [ ] bi* -> setMainFrameURL: ; From 4402d8652cff9af4c164db61fe6d7e76257d5280 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Jul 2009 22:51:53 -0500 Subject: [PATCH 12/28] compiler.cfg.linear-scan: minor fixes --- .../allocation/splitting/splitting.factor | 7 ++++--- .../cfg/linear-scan/assignment/assignment.factor | 14 ++++++-------- .../live-intervals/live-intervals.factor | 2 +- 3 files changed, 11 insertions(+), 12 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index e31fcedace..b2872ace14 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -62,11 +62,12 @@ HINTS: split-interval live-interval object ; 2dup [ compute-start/end ] bi@ ; : insert-use-for-copy ( seq n -- seq' ) - dup 1 + [ nip 1array split1 ] 2keep 2array glue ; + [ '[ _ < ] filter ] + [ nip dup 1 + 2array ] + [ 1 + '[ _ > ] filter ] + 2tri 3append ; : split-before-use ( new n -- before after ) - ! Find optimal split position - ! Insert move instruction 1 - 2dup swap covers? [ [ '[ _ insert-use-for-copy ] change-uses ] keep diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 6b7fdd8ce1..8a9bfa02db 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -51,7 +51,7 @@ ERROR: already-spilled ; : record-spill ( live-interval -- ) [ dup spill-to>> ] [ vreg>> spill-slots-for ] bi - 2dup key? [ already-spilled ] [ set-at ] if ; + 2dup key? drop set-at ; ! [ already-spilled ] [ set-at ] if ; : insert-spill ( live-interval -- ) { @@ -109,7 +109,7 @@ ERROR: already-reloaded ; #! Any live intervals which start on the current instruction #! are added to the active set. unhandled-intervals get dup heap-empty? [ 2drop ] [ - 2dup heap-peek drop start>> = [ + 2dup heap-peek drop start>> >= [ heap-pop drop [ add-active ] [ handle-reload ] bi activate-new-intervals @@ -137,13 +137,11 @@ ERROR: overlapping-registers intervals ; : active-intervals ( n -- intervals ) pending-intervals get [ covers? ] with filter - check-assignment? get [ - dup check-assignment - ] when ; + check-assignment? get [ dup check-assignment ] when ; M: vreg-insn assign-registers-in-insn - dup [ insn#>> active-intervals ] [ all-vregs ] bi - '[ vreg>> _ member? ] filter + dup [ all-vregs ] [ insn#>> active-intervals ] bi + '[ _ [ vreg>> = ] with find nip ] map register-mapping >>regs drop ; @@ -171,7 +169,7 @@ M: ##gc assign-registers-in-insn M: insn assign-registers-in-insn drop ; : begin-block ( bb -- ) - dup block-from 1 - prepare-insn + dup block-from prepare-insn [ block-from compute-live-values ] keep register-live-ins get set-at ; : end-block ( bb -- ) 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 ca8140f1c6..61432eefdf 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -57,7 +57,7 @@ ERROR: dead-value-error vreg ; V{ } clone >>ranges swap >>vreg ; -: block-from ( bb -- n ) instructions>> first insn#>> ; +: block-from ( bb -- n ) instructions>> first insn#>> 1 - ; : block-to ( bb -- n ) instructions>> last insn#>> ; From da01ae5cda66ec100438f5972ff1eb94387d1638 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Mon, 6 Jul 2009 20:57:51 +1200 Subject: [PATCH 13/28] Added alien.inline.types (forgot to add several commits ago) --- basis/alien/inline/inline.factor | 32 ++++-------------- basis/alien/inline/types/authors.txt | 1 + basis/alien/inline/types/types.factor | 47 +++++++++++++++++++++++++++ 3 files changed, 54 insertions(+), 26 deletions(-) create mode 100644 basis/alien/inline/types/authors.txt create mode 100644 basis/alien/inline/types/types.factor diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 9a9f2eb683..ae4a95497a 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.inline.compiler alien.libraries -alien.parser arrays assocs effects fry generalizations grouping -io.files io.files.info io.files.temp kernel lexer math -math.order math.ranges multiline namespaces sequences splitting -strings system vocabs.loader vocabs.parser words ; +USING: accessors alien.inline.compiler alien.inline.types +alien.libraries alien.parser arrays assocs effects fry +generalizations grouping io.files io.files.info io.files.temp +kernel lexer math math.order math.ranges multiline namespaces +sequences splitting strings system vocabs.loader +vocabs.parser words ; IN: alien.inline > ] [ out>> ] bi [ - zip - [ over pointer-to-primitive? [ ">" prepend ] when ] - assoc-map unzip - ] dip ; - - : function-types-effect ( -- function types effect ) scan scan swap ")" parse-tokens [ "(" subseq? not ] filter swap parse-arglist ; -: types-effect>params-return ( types effect -- params return ) - [ in>> zip ] - [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ] - 2bi ; - : arg-list ( types -- params ) CHAR: a swap length CHAR: a + [a,b] [ 1string ] map ; -: factorize-type ( str -- str' ) - "const-" ?head drop - "unsigned-" ?head [ "u" prepend ] when - "long-" ?head [ "long" prepend ] when ; - -: cify-type ( str -- str' ) - { { CHAR: - CHAR: space } } substitute ; - : factor-function ( function types effect -- word quot effect ) annotate-effect [ c-library get ] 3dip [ [ factorize-type ] map ] dip diff --git a/basis/alien/inline/types/authors.txt b/basis/alien/inline/types/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/basis/alien/inline/types/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/basis/alien/inline/types/types.factor b/basis/alien/inline/types/types.factor new file mode 100644 index 0000000000..acc62a81a2 --- /dev/null +++ b/basis/alien/inline/types/types.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2009 Jeremy Hughes. +! 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 ; +IN: alien.inline.types + +: factorize-type ( str -- str' ) + "const-" ?head drop + "unsigned-" ?head [ "u" prepend ] when + "long-" ?head [ "long" prepend ] when ; + +: cify-type ( str -- str' ) + { { CHAR: - CHAR: space } } substitute ; + +: const-type? ( str -- ? ) + "const-" head? ; + +MEMO: resolved-primitives ( -- seq ) + primitive-types [ resolve-typedef ] map ; + +: primitive-type? ( type -- ? ) + [ + factorize-type resolve-typedef [ resolved-primitives ] dip + '[ _ = ] any? + ] [ 2drop f ] recover ; + +: pointer? ( type -- ? ) + [ "*" tail? ] [ "&" tail? ] bi or ; + +: type-sans-pointer ( type -- type' ) + [ '[ _ = ] "*&" swap any? ] trim-tail ; + +: pointer-to-primitive? ( type -- ? ) + { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ; + +: types-effect>params-return ( types effect -- params return ) + [ in>> zip ] + [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ] + 2bi ; + +: annotate-effect ( types effect -- types effect' ) + [ in>> ] [ out>> ] bi [ + zip + [ over pointer-to-primitive? [ ">" prepend ] when ] + assoc-map unzip + ] dip ; From 5484bd3241dc437b1f4deced474cd9a7c2a70f13 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Jul 2009 04:23:26 -0500 Subject: [PATCH 14/28] vocabs.hierachy: redo with cleaner API --- basis/vocabs/hierarchy/hierarchy-docs.factor | 16 ++- basis/vocabs/hierarchy/hierarchy.factor | 101 ++++++++++--------- 2 files changed, 60 insertions(+), 57 deletions(-) diff --git a/basis/vocabs/hierarchy/hierarchy-docs.factor b/basis/vocabs/hierarchy/hierarchy-docs.factor index 3bea362582..be719975c1 100644 --- a/basis/vocabs/hierarchy/hierarchy-docs.factor +++ b/basis/vocabs/hierarchy/hierarchy-docs.factor @@ -7,19 +7,18 @@ $nl "Loading vocabulary hierarchies:" { $subsection load } { $subsection load-all } -"Getting all vocabularies on disk:" +"Getting all vocabularies from disk:" { $subsection all-vocabs } -{ $subsection all-vocabs-seq } -"Getting " { $link "vocabs.metadata" } " for all vocabularies on disk:" +{ $subsection all-vocabs-recursive } +"Getting all vocabularies from disk whose names which match a string prefix:" +{ $subsection child-vocabs } +{ $subsection child-vocabs-recursive } +"Getting " { $link "vocabs.metadata" } " for all vocabularies from disk:" { $subsection all-tags } { $subsection all-authors } ; ABOUT: "vocabs.hierarchy" -HELP: all-vocabs -{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } } -{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ; - HELP: load { $values { "prefix" string } } { $description "Load all vocabularies that match the provided prefix." } @@ -28,6 +27,3 @@ HELP: load HELP: load-all { $description "Load all vocabularies in the source tree." } ; -HELP: all-vocabs-under -{ $values { "prefix" string } { "vocabs" "a sequence of vocabularies" } } -{ $description "Return a sequence of vocab or vocab-links for each vocab matching the provided prefix. Unlike " { $link all-child-vocabs } " this word will return both loaded and unloaded vocabularies." } ; diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor index 046ccb8c2d..6e6dc9cb7e 100644 --- a/basis/vocabs/hierarchy/hierarchy.factor +++ b/basis/vocabs/hierarchy/hierarchy.factor @@ -1,11 +1,18 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs combinators.short-circuit fry +USING: accessors arrays assocs combinators.short-circuit fry io.directories io.files io.files.info io.pathnames kernel make memoize namespaces sequences sorting splitting vocabs sets vocabs.loader vocabs.metadata vocabs.errors ; +RENAME: child-vocabs vocabs => vocabs:child-vocabs IN: vocabs.hierarchy +TUPLE: vocab-prefix name ; + +C: vocab-prefix + +M: vocab-prefix vocab-name name>> ; + vocab-link , ] when - vocabs-in-dir - ] with each ; +: (child-vocabs) ( root prefix -- vocabs ) + [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ] + [ nip [ '[ [ _ "." ] dip 3append ] map ] unless-empty ] + [ drop '[ _ over vocab-dir? [ >vocab-link ] [ ] if ] map ] + 2tri ; -PRIVATE> +: ((child-vocabs-recursive)) ( root name -- ) + dupd vocab-name (child-vocabs) + [ dup , ((child-vocabs-recursive)) ] with each ; -: all-vocabs ( -- assoc ) - vocab-roots get [ - dup [ "" vocabs-in-dir ] { } make - ] { } map>assoc ; +: (child-vocabs-recursive) ( root name -- seq ) + [ ((child-vocabs-recursive)) ] { } make ; -: all-vocabs-under ( prefix -- vocabs ) - [ - [ vocab-roots get ] dip '[ _ vocabs-in-dir ] each - ] { } make ; +: no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ; -MEMO: all-vocabs-seq ( -- seq ) - "" all-vocabs-under ; - - -: all-child-vocabs ( prefix -- assoc ) - vocab-roots get [ - dup pick (all-child-vocabs) [ >vocab-link ] map - ] { } map>assoc - swap unrooted-child-vocabs f swap 2array suffix ; +: no-prefixes ( seq -- seq' ) [ vocab-prefix? not ] filter ; -: all-child-vocabs-seq ( prefix -- assoc ) - vocab-roots get swap '[ - dup _ (all-child-vocabs) - [ vocab-dir? ] with filter - ] map concat ; +: no-roots ( assoc -- seq ) values concat ; + +: child-vocabs ( prefix -- assoc ) + [ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ] + [ unrooted-child-vocabs [ vocab ] map f swap 2array ] + bi suffix ; + +: all-vocabs ( -- assoc ) + "" child-vocabs ; + +: child-vocabs-recursive ( prefix -- assoc ) + [ [ vocab-roots get ] dip '[ dup _ (child-vocabs-recursive) ] { } map>assoc ] + [ unrooted-child-vocabs-recursive [ vocab ] map f swap 2array ] + bi suffix ; + +MEMO: all-vocabs-recursive ( -- assoc ) + "" child-vocabs-recursive ; + +: all-vocab-names ( -- seq ) + all-vocabs-recursive no-roots no-prefixes [ vocab-name ] map ; : (load) ( prefix -- failures ) - all-vocabs-under + child-vocabs-recursive filter-unportable require-all ; @@ -92,8 +101,6 @@ PRIVATE> : load-all ( -- ) "" load ; -MEMO: all-tags ( -- seq ) - all-vocabs-seq [ vocab-tags ] gather natural-sort ; +MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ; -MEMO: all-authors ( -- seq ) - all-vocabs-seq [ vocab-authors ] gather natural-sort ; \ No newline at end of file +MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ; From 4d950dee9a8311d6e5917e7a1ac1e3a1b450ac83 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Jul 2009 04:24:01 -0500 Subject: [PATCH 15/28] help.html: escape # in word names. Reported by ex_rzrjck --- basis/help/html/html.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index fbfc42829e..725a2c6d8f 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -24,6 +24,7 @@ IN: help.html { CHAR: / "__slash__" } { CHAR: , "__comma__" } { CHAR: @ "__at__" } + { CHAR: # "__hash__" } } at [ % ] [ , ] ?if ] [ number>string "__" "__" surround % ] if ; From 994b142f742260ce2b0ce5e3175b1e006eccbdfa Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Mon, 6 Jul 2009 21:34:27 +1200 Subject: [PATCH 16/28] alien.inline.compiler: use g++ for C++ files --- basis/alien/inline/compiler/compiler.factor | 34 +++++++++++++-------- 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/basis/alien/inline/compiler/compiler.factor b/basis/alien/inline/compiler/compiler.factor index 0ac702478b..b5a7861d6b 100644 --- a/basis/alien/inline/compiler/compiler.factor +++ b/basis/alien/inline/compiler/compiler.factor @@ -21,23 +21,33 @@ SYMBOL: C++ { C++ [ ".cpp" ] } } case ; +: compiler ( lang -- str ) + { + { C [ "gcc" ] } + { C++ [ "g++" ] } + } case ; + +: link-command ( in out lang -- descr ) + compiler os { + { [ dup linux? ] + [ drop { "-shared" "-o" } ] } + { [ dup macosx? ] + [ drop { "-g" "-prebind" "-dynamiclib" "-o" } ] } + [ name>> "unimplemented for: " prepend throw ] + } cond swap prefix prepend prepend ; + :: compile-to-object ( lang contents name -- ) name ".o" append temp-file contents name lang src-suffix append temp-file [ ascii set-file-contents ] keep 2array - { "gcc" "-fPIC" "-c" "-o" } prepend try-process ; + { "-fPIC" "-c" "-o" } lang compiler prefix prepend + try-process ; -: link-object ( args name -- ) - [ "lib" prepend library-suffix append ] [ ".o" append ] bi - [ temp-file ] bi@ 2array - os { - { [ dup linux? ] - [ drop { "gcc" "-shared" "-o" } ] } - { [ dup macosx? ] - [ drop { "gcc" "-g" "-prebind" "-dynamiclib" "-o" } ] } - [ name>> "unimplemented for: " prepend throw ] - } cond prepend prepend try-process ; +:: link-object ( lang args name -- ) + args name [ "lib" prepend library-suffix append ] + [ ".o" append ] bi [ temp-file ] bi@ 2array + lang link-command try-process ; :: compile-to-library ( lang args contents name -- ) lang contents name compile-to-object - args name link-object ; + lang args name link-object ; From bcdd94d50ae16666cad06e2c32d38c739c066514 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Jul 2009 04:35:00 -0500 Subject: [PATCH 17/28] help.html: Update for vocabs.hierarchy changes --- basis/help/html/html.factor | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 725a2c6d8f..c2f1ddf2c6 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -5,7 +5,8 @@ io.files io.files.temp io.directories html.streams help kernel assocs sequences make words accessors arrays help.topics vocabs vocabs.hierarchy help.vocabs namespaces prettyprint io vocabs.loader serialize fry memoize unicode.case math.order -sorting debugger html xml.syntax xml.writer math.parser ; +sorting debugger html xml.syntax xml.writer math.parser +sets hashtables ; FROM: io.encodings.ascii => ascii ; FROM: ascii => ascii? ; IN: help.html @@ -71,10 +72,18 @@ M: topic url-of topic>filename ; : generate-help-file ( topic -- ) dup topic>filename utf8 [ help>html write-xml ] with-file-writer ; -: all-vocabs-really ( -- seq ) +: remove-redundant-prefixes ( seq -- seq' ) #! Hack. - all-vocabs values concat - vocabs [ find-vocab-root not ] filter [ vocab ] map append ; + [ vocab-prefix? ] partition + [ + [ vocab-name ] map unique + '[ name>> _ key? not ] filter + [ name>> vocab-link boa ] map + ] keep + append ; + +: all-vocabs-really ( -- seq ) + all-vocabs >hashtable f over delete-at no-roots remove-redundant-prefixes ; : all-topics ( -- topics ) [ From daed003f33518b0a6a2e58901223db2b1ef3d7fb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Jul 2009 04:55:23 -0500 Subject: [PATCH 18/28] vocabs.hierarchy: more refactoring, update existing code for new API --- basis/editors/editors.factor | 5 +++-- basis/help/apropos/apropos.factor | 3 ++- basis/help/html/html.factor | 10 ---------- basis/help/lint/lint.factor | 3 ++- basis/help/vocabs/vocabs.factor | 6 ++++-- basis/present/present-tests.factor | 2 +- basis/tools/completion/completion.factor | 2 +- basis/vocabs/cache/cache.factor | 2 +- basis/vocabs/hierarchy/hierarchy-docs.factor | 3 +++ basis/vocabs/hierarchy/hierarchy.factor | 16 ++++++++++++++++ extra/benchmark/benchmark.factor | 4 ++-- extra/fuel/help/help.factor | 6 +++--- extra/fuel/xref/xref.factor | 2 +- 13 files changed, 39 insertions(+), 25 deletions(-) diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index f81490bcf2..da6a589031 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -3,8 +3,9 @@ USING: parser lexer kernel namespaces sequences definitions io.files io.backend io.pathnames io summary continuations tools.crossref vocabs.hierarchy prettyprint source-files -source-files.errors assocs vocabs vocabs.loader splitting +source-files.errors assocs vocabs.loader splitting accessors debugger help.topics ; +FROM: vocabs => vocab-name >vocab-link ; IN: editors TUPLE: no-edit-hook ; @@ -15,7 +16,7 @@ M: no-edit-hook summary SYMBOL: edit-hook : available-editors ( -- seq ) - "editors" all-child-vocabs-seq [ vocab-name ] map ; + "editors" child-vocabs no-roots no-prefixes [ vocab-name ] map ; : editor-restarts ( -- alist ) available-editors diff --git a/basis/help/apropos/apropos.factor b/basis/help/apropos/apropos.factor index 63cbcb3f1e..3bcc815191 100644 --- a/basis/help/apropos/apropos.factor +++ b/basis/help/apropos/apropos.factor @@ -42,7 +42,8 @@ M: more-completions article-content [ dup name>> >lower ] { } map>assoc ; : vocab-candidates ( -- candidates ) - all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ; + all-vocabs-recursive no-roots no-prefixes + [ dup vocab-name >lower ] { } map>assoc ; : help-candidates ( seq -- candidates ) [ [ >link ] [ article-title >lower ] bi ] { } map>assoc diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index c2f1ddf2c6..84f708a687 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -72,16 +72,6 @@ M: topic url-of topic>filename ; : generate-help-file ( topic -- ) dup topic>filename utf8 [ help>html write-xml ] with-file-writer ; -: remove-redundant-prefixes ( seq -- seq' ) - #! Hack. - [ vocab-prefix? ] partition - [ - [ vocab-name ] map unique - '[ name>> _ key? not ] filter - [ name>> vocab-link boa ] map - ] keep - append ; - : all-vocabs-really ( -- seq ) all-vocabs >hashtable f over delete-at no-roots remove-redundant-prefixes ; diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 1fb836427a..e0cea42b4f 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -5,6 +5,7 @@ help.topics io kernel namespaces parser sequences source-files.errors vocabs.hierarchy vocabs words classes locals tools.errors listener ; FROM: help.lint.checks => all-vocabs ; +FROM: vocabs => child-vocabs ; IN: help.lint SYMBOL: lint-failures @@ -79,7 +80,7 @@ PRIVATE> : help-lint ( prefix -- ) [ auto-use? off - all-vocabs-seq [ vocab-name ] map all-vocabs set + all-vocab-names all-vocabs set group-articles vocab-articles set child-vocabs [ check-vocab ] each diff --git a/basis/help/vocabs/vocabs.factor b/basis/help/vocabs/vocabs.factor index b23143e572..7d99493691 100644 --- a/basis/help/vocabs/vocabs.factor +++ b/basis/help/vocabs/vocabs.factor @@ -8,6 +8,7 @@ help.topics io io.files io.pathnames io.styles kernel macros make namespaces prettyprint sequences sets sorting summary vocabs vocabs.files vocabs.hierarchy vocabs.loader vocabs.metadata words words.symbol definitions.icons ; +FROM: vocabs.hierarchy => child-vocabs ; IN: help.vocabs : about ( vocab -- ) @@ -35,7 +36,7 @@ IN: help.vocabs $heading ; : $vocabs ( seq -- ) - [ vocab-row ] map vocab-headings prefix $table ; + convert-prefixes [ vocab-row ] map vocab-headings prefix $table ; : $vocab-roots ( assoc -- ) [ @@ -67,7 +68,8 @@ C: vocab-author ] unless-empty ; : describe-children ( vocab -- ) - vocab-name all-child-vocabs $vocab-roots ; + vocab-name child-vocabs + $vocab-roots ; : files. ( seq -- ) snippet-style get [ diff --git a/basis/present/present-tests.factor b/basis/present/present-tests.factor index e908fd8147..96aa7b24f2 100644 --- a/basis/present/present-tests.factor +++ b/basis/present/present-tests.factor @@ -5,4 +5,4 @@ USING: tools.test vocabs.hierarchy present math vocabs sequences kernel ; [ "Hi" ] [ "Hi" present ] unit-test [ "+" ] [ \ + present ] unit-test [ "kernel" ] [ "kernel" vocab present ] unit-test -[ ] [ all-vocabs-seq [ present ] map drop ] unit-test \ No newline at end of file +[ ] [ all-vocabs-recursive no-roots no-prefixes [ present ] map drop ] unit-test \ No newline at end of file diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index c8fd3a6658..fb664c495c 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -75,7 +75,7 @@ IN: tools.completion all-words name-completions ; : vocabs-matching ( str -- seq ) - all-vocabs-seq name-completions ; + all-vocabs-recursive no-roots no-prefixes name-completions ; : chars-matching ( str -- seq ) name-map keys dup zip completions ; diff --git a/basis/vocabs/cache/cache.factor b/basis/vocabs/cache/cache.factor index 63a8d6d292..24ccd391f1 100644 --- a/basis/vocabs/cache/cache.factor +++ b/basis/vocabs/cache/cache.factor @@ -7,7 +7,7 @@ IN: vocabs.cache : reset-cache ( -- ) root-cache get-global clear-assoc \ vocab-file-contents reset-memoized - \ all-vocabs-seq reset-memoized + \ all-vocabs-recursive reset-memoized \ all-authors reset-memoized \ all-tags reset-memoized ; diff --git a/basis/vocabs/hierarchy/hierarchy-docs.factor b/basis/vocabs/hierarchy/hierarchy-docs.factor index be719975c1..8eb39732c0 100644 --- a/basis/vocabs/hierarchy/hierarchy-docs.factor +++ b/basis/vocabs/hierarchy/hierarchy-docs.factor @@ -13,6 +13,9 @@ $nl "Getting all vocabularies from disk whose names which match a string prefix:" { $subsection child-vocabs } { $subsection child-vocabs-recursive } +"Words for modifying output:" +{ $subsection no-roots } +{ $subsection no-prefixes } "Getting " { $link "vocabs.metadata" } " for all vocabularies from disk:" { $subsection all-tags } { $subsection all-authors } ; diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor index 6e6dc9cb7e..b9f9bb2e9b 100644 --- a/basis/vocabs/hierarchy/hierarchy.factor +++ b/basis/vocabs/hierarchy/hierarchy.factor @@ -58,6 +58,19 @@ PRIVATE> : no-prefixes ( seq -- seq' ) [ vocab-prefix? not ] filter ; +: convert-prefixes ( seq -- seq' ) + [ dup vocab-prefix? [ name>> vocab-link boa ] when ] map ; + +: remove-redundant-prefixes ( seq -- seq' ) + #! Hack. + [ vocab-prefix? ] partition + [ + [ vocab-name ] map unique + '[ name>> _ key? not ] filter + convert-prefixes + ] keep + append ; + : no-roots ( assoc -- seq ) values concat ; : child-vocabs ( prefix -- assoc ) @@ -79,6 +92,9 @@ MEMO: all-vocabs-recursive ( -- assoc ) : all-vocab-names ( -- seq ) all-vocabs-recursive no-roots no-prefixes [ vocab-name ] map ; +: child-vocab-names ( prefix -- seq ) + child-vocabs no-roots no-prefixes [ vocab-name ] map ; + : run-benchmark ( vocab -- ) - [ "=== " write vocab-name print flush ] [ + [ "=== " write print flush ] [ [ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ] [ swap errors ] recover get set-at @@ -23,7 +23,7 @@ PRIVATE> [ V{ } clone timings set V{ } clone errors set - "benchmark" all-child-vocabs-seq + "benchmark" child-vocab-names [ run-benchmark ] each timings get errors get diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index f20e67f9bc..dcf5d69a74 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -6,7 +6,7 @@ help.markup help.topics io io.streams.string kernel make namespaces parser prettyprint sequences summary help.vocabs vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see listener ; - +FROM: vocabs.hierarchy => child-vocabs ; IN: fuel.help map [ ] filter ; + ] { } assoc>map sift ; : fuel-vocab-children-help ( name -- element ) - all-child-vocabs fuel-vocab-list ; inline + child-vocabs fuel-vocab-list ; inline : fuel-vocab-describe-words ( name -- element ) [ words. ] with-string-writer \ describe-words swap 2array ; inline diff --git a/extra/fuel/xref/xref.factor b/extra/fuel/xref/xref.factor index 608667bae7..86aa215e21 100644 --- a/extra/fuel/xref/xref.factor +++ b/extra/fuel/xref/xref.factor @@ -64,7 +64,7 @@ PRIVATE> : article-location ( name -- loc ) article loc>> get-loc ; -: get-vocabs ( -- seq ) all-vocabs-seq [ vocab-name ] map ; +: get-vocabs ( -- seq ) all-vocab-names ; : get-vocabs/prefix ( prefix -- seq ) get-vocabs swap filter-prefix ; From d56e818beba0f512343944b44d07179aa741835f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Jul 2009 05:22:01 -0500 Subject: [PATCH 19/28] vocabs.hierarchy: fix (load) word --- basis/vocabs/hierarchy/hierarchy.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor index b9f9bb2e9b..aa3e619660 100644 --- a/basis/vocabs/hierarchy/hierarchy.factor +++ b/basis/vocabs/hierarchy/hierarchy.factor @@ -107,7 +107,7 @@ MEMO: all-vocabs-recursive ( -- assoc ) PRIVATE> : (load) ( prefix -- failures ) - child-vocabs-recursive + child-vocabs-recursive no-roots no-prefixes filter-unportable require-all ; From 328c6d02f53a5657eda9d1fc4123df344a67ed1a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Jul 2009 23:19:26 -0500 Subject: [PATCH 20/28] ui.gadgets.tables: clicking in empty area no longer notifies selection model --- basis/ui/gadgets/tables/tables.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 390e652ac6..3beb0af79f 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -313,13 +313,14 @@ PRIVATE> if ; : row-action? ( table -- ? ) - [ [ mouse-row ] keep valid-line? ] - [ single-click?>> hand-click# get 2 = or ] bi and ; + single-click?>> hand-click# get 2 = or ; From 0bcf4ce535ed990c054d2f29912fb51210ed1f64 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 03:28:55 -0500 Subject: [PATCH 21/28] compiler.cfg.linear-scan: Re-implement spilling, add some additional runtime assertions, simplify assignment pass since it doesn't have to track spill slots anymore; just assume a live value that's not in active or inactive is spilled --- .../linear-scan/allocation/allocation.factor | 13 +- .../allocation/coalescing/coalescing.factor | 6 +- .../allocation/spilling/spilling.factor | 144 ++++-- .../allocation/splitting/splitting.factor | 13 +- .../linear-scan/allocation/state/state.factor | 19 +- .../linear-scan/assignment/assignment.factor | 71 ++- .../cfg/linear-scan/debugger/debugger.factor | 7 +- .../cfg/linear-scan/linear-scan-tests.factor | 450 +++++++++++++----- .../live-intervals/live-intervals.factor | 12 +- 9 files changed, 508 insertions(+), 227 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 4a58064582..7dd3977605 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -9,11 +9,6 @@ compiler.cfg.linear-scan.allocation.splitting compiler.cfg.linear-scan.allocation.state ; IN: compiler.cfg.linear-scan.allocation -: free-positions ( new -- assoc ) - vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ; - -: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ; - : active-positions ( new assoc -- ) [ vreg>> active-intervals-for ] dip '[ [ 0 ] dip reg>> _ add-use-position ] each ; @@ -21,7 +16,7 @@ IN: compiler.cfg.linear-scan.allocation : inactive-positions ( new assoc -- ) [ [ vreg>> inactive-intervals-for ] keep ] dip '[ - [ _ relevant-ranges intersect-live-ranges ] [ reg>> ] bi + [ _ relevant-ranges intersect-live-ranges 1/0. or ] [ reg>> ] bi _ add-use-position ] each ; @@ -33,12 +28,6 @@ IN: compiler.cfg.linear-scan.allocation : no-free-registers? ( result -- ? ) second 0 = ; inline -: register-available? ( new result -- ? ) - [ end>> ] [ second ] bi* < ; inline - -: register-available ( new result -- ) - first >>reg add-active ; - : register-partially-available ( new result -- ) [ second split-before-use ] keep '[ _ register-available ] [ add-unhandled ] bi* ; diff --git a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor index b2b9202204..e99c2ba710 100644 --- a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor +++ b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor @@ -9,15 +9,15 @@ IN: compiler.cfg.linear-scan.allocation.coalescing : active-interval ( vreg -- live-interval ) dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ; -: intersects-inactive-intervals? ( live-interval -- ? ) +: avoids-inactive-intervals? ( live-interval -- ? ) dup vreg>> inactive-intervals-for - [ relevant-ranges intersect-live-ranges 1/0. = ] with all? ; + [ intervals-intersect? not ] with all? ; : coalesce? ( live-interval -- ? ) { [ copy-from>> active-interval ] [ [ start>> ] [ copy-from>> active-interval end>> ] bi = ] - [ intersects-inactive-intervals? ] + [ avoids-inactive-intervals? ] } 1&& ; : coalesce ( live-interval -- ) diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index e5c4b10021..9be80b0775 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -1,23 +1,13 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators fry hints kernel locals -math sequences sets sorting splitting compiler.utilities namespaces +math sequences sets sorting splitting namespaces +combinators.short-circuit compiler.utilities compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.allocation.splitting compiler.cfg.linear-scan.live-intervals ; IN: compiler.cfg.linear-scan.allocation.spilling -: find-use ( live-interval n quot -- elt ) - [ uses>> ] 2dip curry find nip ; inline - -: interval-to-spill ( active-intervals current -- live-interval ) - #! We spill the interval with the most distant use location. - #! If an active interval has no more use positions, find-use - #! returns f. This occurs if the interval is a split. In - #! this case, we prefer to spill this interval always. - start>> '[ dup _ [ >= ] find-use 1/0. or ] { } map>assoc - alist-max first ; - ERROR: bad-live-ranges interval ; : check-ranges ( live-interval -- ) @@ -47,52 +37,106 @@ ERROR: bad-live-ranges interval ; [ ] } 2cleave ; -: assign-spill ( live-interval -- live-interval ) - dup vreg>> assign-spill-slot >>spill-to ; +: assign-spill ( live-interval -- ) + dup vreg>> assign-spill-slot >>spill-to drop ; -: assign-reload ( before after -- before after ) - over spill-to>> >>reload-from ; +: assign-reload ( live-interval -- ) + dup vreg>> assign-spill-slot >>reload-from drop ; -: split-and-spill ( new existing -- before after ) - swap start>> split-for-spill [ assign-spill ] dip assign-reload ; +: split-and-spill ( live-interval n -- before after ) + split-for-spill + [ [ assign-spill ] [ assign-reload ] bi* ] + [ [ t >>record-spill? ] [ t >>record-reload? ] bi* ] 2bi ; -: reuse-register ( new existing -- ) - [ nip delete-active ] - [ reg>> >>reg add-active ] 2bi ; +: find-use-position ( live-interval new -- n ) + [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ; -: spill-existing? ( new existing -- ? ) - #! Test if 'new' will be used before 'existing'. - over start>> '[ _ [ > ] find-use -1 or ] bi@ < ; +: find-use-positions ( live-intervals new assoc -- ) + '[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ; -: spill-existing ( new existing -- ) - #! Our new interval will be used before the active interval - #! with the most distant use location. Spill the existing - #! interval, then process the new interval and the tail end - #! of the existing interval again. - [ reuse-register ] - [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2bi ; +: active-positions ( new assoc -- ) + [ [ vreg>> active-intervals-for ] keep ] dip + find-use-positions ; -: spill-live-out? ( new existing -- ? ) - [ start>> ] [ uses>> last ] bi* > ; +: inactive-positions ( new assoc -- ) + [ + [ vreg>> inactive-intervals-for ] keep + [ '[ _ intervals-intersect? ] filter ] keep + ] dip + find-use-positions ; -: spill-live-out ( new existing -- ) - #! The existing interval is never used again. Spill it and - #! re-use the register. - assign-spill - [ reuse-register ] - [ nip add-handled ] 2bi ; +: spill-status ( new -- use-pos ) + H{ } clone + [ inactive-positions ] [ active-positions ] [ nip ] 2tri + >alist alist-max ; -: spill-new ( new existing -- ) - #! Our new interval will be used after the active interval - #! with the most distant use location. Split the new - #! interval, then process both parts of the new interval - #! again. - [ dup split-and-spill add-unhandled ] dip spill-existing ; +: spill-new? ( new pair -- ? ) + [ uses>> first ] [ second ] bi* > ; -: assign-blocked-register ( new -- ) - [ dup vreg>> active-intervals-for ] keep interval-to-spill { - { [ 2dup spill-live-out? ] [ spill-live-out ] } - { [ 2dup spill-existing? ] [ spill-existing ] } - [ spill-new ] +: spill-new ( new pair -- ) + "not sure what to do yet" throw ; + +: split-intersecting? ( live-interval new reg -- ? ) + { [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ; + +: split-live-out ( live-interval -- ) + f >>record-spill? + { + [ trim-before-ranges ] + [ compute-start/end ] + [ assign-spill ] + [ add-handled ] + } cleave ; + +: split-live-in ( live-interval -- ) + f >>record-reload? + { + [ trim-after-ranges ] + [ compute-start/end ] + ! [ assign-reload ] + [ add-handled ] + } cleave ; + +: (split-intersecting) ( live-interval new -- ) + start>> { + { [ 2dup [ uses>> last ] dip < ] [ drop split-live-out ] } + { [ 2dup [ uses>> first ] dip > ] [ drop split-live-in ] } + [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] } cond ; +: (split-intersecting-active) ( active new -- ) + [ drop delete-active ] + [ (split-intersecting) ] 2bi ; + +: split-intersecting-active ( new reg -- ) + [ [ vreg>> active-intervals-for ] keep ] dip + [ '[ _ _ split-intersecting? ] filter ] 2keep drop + '[ _ (split-intersecting-active) ] each ; + +: (split-intersecting-inactive) ( inactive new -- ) + [ drop delete-inactive ] + [ (split-intersecting) ] 2bi ; + +: split-intersecting-inactive ( new reg -- ) + [ [ vreg>> inactive-intervals-for ] keep ] dip + [ '[ _ _ split-intersecting? ] filter ] 2keep drop + '[ _ (split-intersecting-inactive) ] each ; + +: split-intersecting ( new reg -- ) + [ split-intersecting-active ] + [ split-intersecting-inactive ] + 2bi ; + +: spill-available ( new pair -- ) + [ first split-intersecting ] [ register-available ] 2bi ; + +: spill-partially-available ( new pair -- ) + [ second 1 - split-and-spill add-unhandled ] keep + spill-available ; + +: assign-blocked-register ( new -- ) + dup spill-status { + { [ 2dup spill-new? ] [ spill-new ] } + { [ 2dup register-available? ] [ spill-available ] } + [ spill-partially-available ] + } cond ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index b2872ace14..71d3d56285 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators fry hints kernel locals -math sequences sets sorting splitting +math sequences sets sorting splitting namespaces compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.live-intervals ; IN: compiler.cfg.linear-scan.allocation.splitting @@ -32,12 +32,17 @@ IN: compiler.cfg.linear-scan.allocation.splitting ERROR: splitting-too-early ; +ERROR: splitting-too-late ; + ERROR: splitting-atomic-interval ; : check-split ( live-interval n -- ) - [ [ start>> ] dip > [ splitting-too-early ] when ] - [ drop [ end>> ] [ start>> ] bi - 0 = [ splitting-atomic-interval ] when ] - 2bi ; inline + check-allocation? get [ + [ [ start>> ] dip > [ splitting-too-early ] when ] + [ [ end>> ] dip <= [ splitting-too-late ] when ] + [ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ] + 2tri + ] [ 2drop ] if ; inline : split-before ( before -- before' ) f >>spill-to ; inline diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor index a17a1181b5..a08e3e37bd 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators cpu.architecture fry heaps -kernel math namespaces sequences vectors +kernel math math.order namespaces sequences vectors compiler.cfg.linear-scan.live-intervals ; IN: compiler.cfg.linear-scan.allocation.state @@ -32,6 +32,9 @@ SYMBOL: inactive-intervals : add-inactive ( live-interval -- ) dup vreg>> inactive-intervals-for push ; +: delete-inactive ( live-interval -- ) + dup vreg>> inactive-intervals-for delq ; + ! Vector of handled live intervals SYMBOL: handled-intervals @@ -133,4 +136,16 @@ SYMBOL: spill-slots : init-unhandled ( live-intervals -- ) [ [ start>> ] keep ] { } map>assoc - unhandled-intervals get heap-push-all ; \ No newline at end of file + unhandled-intervals get heap-push-all ; + +! A utility used by register-status and spill-status words +: free-positions ( new -- assoc ) + vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ; + +: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ; + +: register-available? ( new result -- ? ) + [ end>> ] [ second ] bi* < ; inline + +: register-available ( new result -- ) + first >>reg add-active ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 8a9bfa02db..bc565c6cbb 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -3,7 +3,9 @@ USING: accessors kernel math assocs namespaces sequences heaps fry make combinators sets locals cpu.architecture +compiler.cfg compiler.cfg.def-use +compiler.cfg.liveness compiler.cfg.registers compiler.cfg.instructions compiler.cfg.linear-scan.allocation @@ -27,12 +29,6 @@ SYMBOL: unhandled-intervals : init-unhandled ( live-intervals -- ) [ add-unhandled ] each ; -! Mapping spill slots to vregs -SYMBOL: spill-slots - -: spill-slots-for ( vreg -- assoc ) - reg-class>> spill-slots get at ; - ! Mapping from basic blocks to values which are live at the start SYMBOL: register-live-ins @@ -42,17 +38,10 @@ SYMBOL: register-live-outs : init-assignment ( live-intervals -- ) V{ } clone pending-intervals set unhandled-intervals set - [ H{ } clone ] reg-class-assoc spill-slots set H{ } clone register-live-ins set H{ } clone register-live-outs set init-unhandled ; -ERROR: already-spilled ; - -: record-spill ( live-interval -- ) - [ dup spill-to>> ] [ vreg>> spill-slots-for ] bi - 2dup key? drop set-at ; ! [ already-spilled ] [ set-at ] if ; - : insert-spill ( live-interval -- ) { [ reg>> ] @@ -62,7 +51,7 @@ ERROR: already-spilled ; } cleave f swap \ _spill boa , ; : handle-spill ( live-interval -- ) - dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ; + dup spill-to>> [ insert-spill ] [ drop ] if ; : first-split ( live-interval -- live-interval' ) dup split-before>> [ first-split ] [ ] ?if ; @@ -88,12 +77,6 @@ ERROR: already-spilled ; [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if ] filter-here ; -ERROR: already-reloaded ; - -: record-reload ( live-interval -- ) - [ reload-from>> ] [ vreg>> spill-slots-for ] bi - 2dup key? [ delete-at ] [ already-reloaded ] if ; - : insert-reload ( live-interval -- ) { [ reg>> ] @@ -103,7 +86,7 @@ ERROR: already-reloaded ; } cleave f swap \ _reload boa , ; : handle-reload ( live-interval -- ) - dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ; + dup reload-from>> [ insert-reload ] [ drop ] if ; : activate-new-intervals ( n -- ) #! Any live intervals which start on the current instruction @@ -145,35 +128,43 @@ M: vreg-insn assign-registers-in-insn register-mapping >>regs drop ; -: compute-live-registers ( n -- assoc ) - active-intervals register-mapping ; - -: compute-live-spill-slots ( -- assocs ) - spill-slots get values first2 - [ [ vreg>> swap ] H{ } assoc-map-as ] bi@ - assoc-union ; - -: compute-live-values ( n -- assoc ) - [ compute-live-spill-slots ] dip compute-live-registers - assoc-union ; - -: compute-live-gc-values ( insn -- assoc ) - [ insn#>> compute-live-values ] [ temp-vregs ] bi - '[ drop _ memq? not ] assoc-filter ; - M: ##gc assign-registers-in-insn + ! This works because ##gc is always the first instruction + ! in a block. dup call-next-method - dup compute-live-gc-values >>live-values + basic-block get register-live-ins get at >>live-values drop ; M: insn assign-registers-in-insn drop ; +: compute-live-spill-slots ( vregs -- assoc ) + spill-slots get '[ _ at dup [ ] when ] assoc-map ; + +: compute-live-registers ( n -- assoc ) + active-intervals register-mapping ; + +ERROR: bad-live-values live-values ; + +: check-live-values ( assoc -- assoc ) + check-assignment? get [ + dup values [ not ] any? [ bad-live-values ] when + ] when ; + +: compute-live-values ( vregs n -- assoc ) + ! If a live vreg is not in active or inactive, then it must have been + ! spilled. + [ compute-live-spill-slots ] [ compute-live-registers ] bi* + assoc-union check-live-values ; + : begin-block ( bb -- ) + dup basic-block set dup block-from prepare-insn - [ block-from compute-live-values ] keep register-live-ins get set-at ; + [ [ live-in ] [ block-from ] bi compute-live-values ] keep + register-live-ins get set-at ; : end-block ( bb -- ) - [ block-to compute-live-values ] keep register-live-outs get set-at ; + [ [ live-out ] [ block-to ] bi compute-live-values ] keep + register-live-outs get set-at ; ERROR: bad-vreg vreg ; diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor index be3fb2bea8..a350ee5f43 100644 --- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor +++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences sets arrays math strings fry namespaces prettyprint compiler.cfg.linear-scan.live-intervals -compiler.cfg.linear-scan.allocation compiler.cfg ; +compiler.cfg.linear-scan.allocation compiler.cfg assocs ; IN: compiler.cfg.linear-scan.debugger : check-assigned ( live-intervals -- ) @@ -19,7 +19,10 @@ IN: compiler.cfg.linear-scan.debugger ] [ 1array ] if ; : check-linear-scan ( live-intervals machine-registers -- ) - [ [ clone ] map ] dip allocate-registers + [ + [ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc + live-intervals set + ] dip allocate-registers [ split-children ] map concat check-assigned ; : picture ( uses -- str ) diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index e3cd9e105f..59e6190b63 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -76,36 +76,6 @@ check-assignment? on { T{ live-range f 0 5 } } 0 split-ranges ] unit-test -[ 7 ] [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 2 } } } - { start 0 } - { end 10 } - { uses V{ 0 1 3 7 10 } } - } - 4 [ >= ] find-use -] unit-test - -[ 4 ] [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 2 } } } - { start 0 } - { end 10 } - { uses V{ 0 1 3 4 10 } } - } - 4 [ >= ] find-use -] unit-test - -[ f ] [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 2 } } } - { start 0 } - { end 10 } - { uses V{ 0 1 3 4 10 } } - } - 100 [ >= ] find-use -] unit-test - [ T{ live-interval { vreg T{ vreg { reg-class int-regs } { n 1 } } } @@ -257,88 +227,82 @@ check-assignment? on ] unit-test [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 3 } - { end 10 } - { uses V{ 3 10 } } + { + 3 + 10 } ] [ + H{ + { int-regs + V{ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { reg 1 } + { start 1 } + { end 15 } + { uses V{ 1 3 7 10 15 } } + } + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 2 } } } + { reg 2 } + { start 3 } + { end 8 } + { uses V{ 3 4 8 } } + } + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 3 } } } + { reg 3 } + { start 3 } + { end 10 } + { uses V{ 3 10 } } + } + } + } + } active-intervals set + H{ } inactive-intervals set + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { start 5 } + { end 5 } + { uses V{ 5 } } + } + spill-status +] unit-test + +[ { - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 1 } - { end 15 } - { uses V{ 1 3 7 10 15 } } - } - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 3 } - { end 8 } - { uses V{ 3 4 8 } } - } - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 3 } - { end 10 } - { uses V{ 3 10 } } - } + 1 + 1/0. } +] [ + H{ + { int-regs + V{ + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { reg 1 } + { start 1 } + { end 15 } + { uses V{ 1 } } + } + T{ live-interval + { vreg T{ vreg { reg-class int-regs } { n 2 } } } + { reg 2 } + { start 3 } + { end 8 } + { uses V{ 3 8 } } + } + } + } + } active-intervals set + H{ } inactive-intervals set T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } + { vreg T{ vreg { reg-class int-regs } { n 3 } } } { start 5 } { end 5 } { uses V{ 5 } } } - interval-to-spill -] unit-test - -[ t ] [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 5 } - { end 15 } - { uses V{ 5 10 15 } } - } - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 1 } - { end 20 } - { uses V{ 1 20 } } - } - spill-existing? -] unit-test - -[ f ] [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 5 } - { end 15 } - { uses V{ 5 10 15 } } - } - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 1 } - { end 20 } - { uses V{ 1 7 20 } } - } - spill-existing? -] unit-test - -[ t ] [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 5 } - { end 5 } - { uses V{ 5 } } - } - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 1 } - { end 20 } - { uses V{ 1 7 20 } } - } - spill-existing? + spill-status ] unit-test [ ] [ @@ -1477,6 +1441,20 @@ USING: math.private ; intersect-live-ranges ] unit-test +[ f ] [ + { + T{ live-range f 0 10 } + T{ live-range f 20 30 } + T{ live-range f 40 50 } + } + { + T{ live-range f 11 15 } + T{ live-range f 31 36 } + T{ live-range f 51 55 } + } + intersect-live-ranges +] unit-test + [ 5 ] [ T{ live-interval { start 0 } @@ -1605,12 +1583,14 @@ V{ SYMBOL: linear-scan-result :: test-linear-scan-on-cfg ( regs -- ) - cfg new 0 get >>entry - compute-predecessors - compute-liveness - dup reverse-post-order - { { int-regs regs } } (linear-scan) - flatten-cfg 1array mr. ; + [ + cfg new 0 get >>entry + compute-predecessors + compute-liveness + dup reverse-post-order + { { int-regs regs } } (linear-scan) + flatten-cfg 1array mr. + ] with-scope ; ! This test has a critical edge -- do we care about these? @@ -2101,3 +2081,255 @@ V{ 5 get 1vector 3 get (>>successors) [ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test + +! Reduction of push-all regression, x86-32 +V{ T{ ##prologue } T{ ##branch } } 0 test-bb + +V{ + T{ ##load-immediate { dst V int-regs 61 } } + T{ ##peek { dst V int-regs 62 } { loc D 0 } } + T{ ##peek { dst V int-regs 64 } { loc D 1 } } + T{ ##slot-imm + { dst V int-regs 69 } + { obj V int-regs 64 } + { slot 1 } + { tag 2 } + } + T{ ##copy { dst V int-regs 79 } { src V int-regs 69 } } + T{ ##slot-imm + { dst V int-regs 85 } + { obj V int-regs 62 } + { slot 2 } + { tag 7 } + } + T{ ##compare-branch + { src1 V int-regs 69 } + { src2 V int-regs 85 } + { cc cc> } + } +} 1 test-bb + +V{ + T{ ##slot-imm + { dst V int-regs 97 } + { obj V int-regs 62 } + { slot 2 } + { tag 7 } + } + T{ ##replace { src V int-regs 79 } { loc D 3 } } + T{ ##replace { src V int-regs 62 } { loc D 4 } } + T{ ##replace { src V int-regs 79 } { loc D 1 } } + T{ ##replace { src V int-regs 62 } { loc D 2 } } + T{ ##replace { src V int-regs 61 } { loc D 5 } } + T{ ##replace { src V int-regs 62 } { loc R 0 } } + T{ ##replace { src V int-regs 69 } { loc R 1 } } + T{ ##replace { src V int-regs 97 } { loc D 0 } } + T{ ##call { word resize-array } } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##peek { dst V int-regs 98 } { loc R 0 } } + T{ ##peek { dst V int-regs 100 } { loc D 0 } } + T{ ##set-slot-imm + { src V int-regs 100 } + { obj V int-regs 98 } + { slot 2 } + { tag 7 } + } + T{ ##peek { dst V int-regs 108 } { loc D 2 } } + T{ ##peek { dst V int-regs 110 } { loc D 3 } } + T{ ##peek { dst V int-regs 112 } { loc D 0 } } + T{ ##peek { dst V int-regs 114 } { loc D 1 } } + T{ ##peek { dst V int-regs 116 } { loc D 4 } } + T{ ##peek { dst V int-regs 119 } { loc R 0 } } + T{ ##copy { dst V int-regs 109 } { src V int-regs 108 } } + T{ ##copy { dst V int-regs 111 } { src V int-regs 110 } } + T{ ##copy { dst V int-regs 113 } { src V int-regs 112 } } + T{ ##copy { dst V int-regs 115 } { src V int-regs 114 } } + T{ ##copy { dst V int-regs 117 } { src V int-regs 116 } } + T{ ##copy { dst V int-regs 120 } { src V int-regs 119 } } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##copy { dst V int-regs 109 } { src V int-regs 62 } } + T{ ##copy { dst V int-regs 111 } { src V int-regs 61 } } + T{ ##copy { dst V int-regs 113 } { src V int-regs 62 } } + T{ ##copy { dst V int-regs 115 } { src V int-regs 79 } } + T{ ##copy { dst V int-regs 117 } { src V int-regs 64 } } + T{ ##copy { dst V int-regs 120 } { src V int-regs 69 } } + T{ ##branch } +} 4 test-bb + +V{ + T{ ##replace { src V int-regs 120 } { loc D 0 } } + T{ ##replace { src V int-regs 109 } { loc D 3 } } + T{ ##replace { src V int-regs 111 } { loc D 4 } } + T{ ##replace { src V int-regs 113 } { loc D 1 } } + T{ ##replace { src V int-regs 115 } { loc D 2 } } + T{ ##replace { src V int-regs 117 } { loc D 5 } } + 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 +3 get 5 get 1vector >>successors drop +4 get 5 get 1vector >>successors drop + +[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test + +! Another reduction of push-all +V{ T{ ##prologue } T{ ##branch } } 0 test-bb + +V{ + T{ ##peek { dst V int-regs 85 } { loc D 0 } } + T{ ##slot-imm + { dst V int-regs 89 } + { obj V int-regs 85 } + { slot 3 } + { tag 7 } + } + T{ ##peek { dst V int-regs 91 } { loc D 1 } } + T{ ##slot-imm + { dst V int-regs 96 } + { obj V int-regs 91 } + { slot 1 } + { tag 2 } + } + T{ ##add + { dst V int-regs 109 } + { src1 V int-regs 89 } + { src2 V int-regs 96 } + } + T{ ##slot-imm + { dst V int-regs 115 } + { obj V int-regs 85 } + { slot 2 } + { tag 7 } + } + T{ ##slot-imm + { dst V int-regs 118 } + { obj V int-regs 115 } + { slot 1 } + { tag 2 } + } + T{ ##compare-branch + { src1 V int-regs 109 } + { src2 V int-regs 118 } + { cc cc> } + } +} 1 test-bb + +V{ + T{ ##add-imm + { dst V int-regs 128 } + { src1 V int-regs 109 } + { src2 8 } + } + T{ ##load-immediate { dst V int-regs 129 } { val 24 } } + T{ ##inc-d { n 4 } } + T{ ##inc-r { n 1 } } + T{ ##replace { src V int-regs 109 } { loc D 2 } } + T{ ##replace { src V int-regs 85 } { loc D 3 } } + T{ ##replace { src V int-regs 128 } { loc D 0 } } + T{ ##replace { src V int-regs 85 } { loc D 1 } } + T{ ##replace { src V int-regs 89 } { loc D 4 } } + T{ ##replace { src V int-regs 96 } { loc R 0 } } + T{ ##fixnum-mul + { src1 V int-regs 128 } + { src2 V int-regs 129 } + { temp1 V int-regs 132 } + { temp2 V int-regs 133 } + } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##peek { dst V int-regs 134 } { loc D 1 } } + T{ ##slot-imm + { dst V int-regs 140 } + { obj V int-regs 134 } + { slot 2 } + { tag 7 } + } + T{ ##inc-d { n 1 } } + T{ ##inc-r { n 1 } } + T{ ##replace { src V int-regs 140 } { loc D 0 } } + T{ ##replace { src V int-regs 134 } { loc R 0 } } + T{ ##call { word resize-array } } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##peek { dst V int-regs 141 } { loc R 0 } } + T{ ##peek { dst V int-regs 143 } { loc D 0 } } + T{ ##set-slot-imm + { src V int-regs 143 } + { obj V int-regs 141 } + { slot 2 } + { tag 7 } + } + T{ ##write-barrier + { src V int-regs 141 } + { card# V int-regs 145 } + { table V int-regs 146 } + } + T{ ##inc-d { n -1 } } + T{ ##inc-r { n -1 } } + T{ ##peek { dst V int-regs 156 } { loc D 2 } } + T{ ##peek { dst V int-regs 158 } { loc D 3 } } + T{ ##peek { dst V int-regs 160 } { loc D 0 } } + T{ ##peek { dst V int-regs 162 } { loc D 1 } } + T{ ##peek { dst V int-regs 164 } { loc D 4 } } + T{ ##peek { dst V int-regs 167 } { loc R 0 } } + T{ ##copy { dst V int-regs 157 } { src V int-regs 156 } } + T{ ##copy { dst V int-regs 159 } { src V int-regs 158 } } + T{ ##copy { dst V int-regs 161 } { src V int-regs 160 } } + T{ ##copy { dst V int-regs 163 } { src V int-regs 162 } } + T{ ##copy { dst V int-regs 165 } { src V int-regs 164 } } + T{ ##copy { dst V int-regs 168 } { src V int-regs 167 } } + T{ ##branch } +} 4 test-bb + +V{ + T{ ##inc-d { n 3 } } + T{ ##inc-r { n 1 } } + T{ ##copy { dst V int-regs 157 } { src V int-regs 85 } } + T{ ##copy { dst V int-regs 159 } { src V int-regs 89 } } + T{ ##copy { dst V int-regs 161 } { src V int-regs 85 } } + T{ ##copy { dst V int-regs 163 } { src V int-regs 109 } } + T{ ##copy { dst V int-regs 165 } { src V int-regs 91 } } + T{ ##copy { dst V int-regs 168 } { src V int-regs 96 } } + T{ ##branch } +} 5 test-bb + +V{ + T{ ##set-slot-imm + { src V int-regs 163 } + { obj V int-regs 161 } + { slot 3 } + { tag 7 } + } + T{ ##inc-d { n 1 } } + T{ ##inc-r { n -1 } } + T{ ##replace { src V int-regs 168 } { loc D 0 } } + T{ ##replace { src V int-regs 157 } { loc D 3 } } + T{ ##replace { src V int-regs 159 } { loc D 4 } } + T{ ##replace { src V int-regs 161 } { loc D 1 } } + T{ ##replace { src V int-regs 163 } { loc D 2 } } + T{ ##replace { src V int-regs 165 } { loc D 5 } } + T{ ##epilogue } + T{ ##return } +} 6 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 5 get V{ } 2sequence >>successors drop +2 get 3 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 + +[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test \ No newline at end of file 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 61432eefdf..e735640b10 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -11,7 +11,7 @@ C: live-range TUPLE: live-interval vreg -reg spill-to reload-from +reg spill-to record-spill? reload-from record-reload? split-before split-after split-next start end ranges uses copy-from ; @@ -145,8 +145,7 @@ M: ##copy-float compute-live-intervals* [ compute-live-intervals-step ] each ] keep values dup finish-live-intervals ; -: relevant-ranges ( new inactive -- new' inactive' ) - ! Slice off all ranges of 'inactive' that precede the start of 'new' +: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 ) [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ; : intersect-live-range ( range1 range2 -- n/f ) @@ -155,8 +154,8 @@ M: ##copy-float compute-live-intervals* : intersect-live-ranges ( ranges1 ranges2 -- n ) { - { [ over empty? ] [ 2drop 1/0. ] } - { [ dup empty? ] [ 2drop 1/0. ] } + { [ over empty? ] [ 2drop f ] } + { [ dup empty? ] [ 2drop f ] } [ 2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [ drop @@ -166,3 +165,6 @@ M: ##copy-float compute-live-intervals* ] if ] } cond ; + +: intervals-intersect? ( interval1 interval2 -- ? ) + relevant-ranges intersect-live-ranges >boolean ; inline \ No newline at end of file From 43c873f00a4e023f851b7ebb0cfe59397f445a11 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 03:45:27 -0500 Subject: [PATCH 22/28] compiler.cfg.linear-scan: code cleanup --- .../cfg/linear-scan/allocation/spilling/spilling.factor | 8 ++------ .../cfg/linear-scan/live-intervals/live-intervals.factor | 2 +- 2 files changed, 3 insertions(+), 7 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 9be80b0775..1bd7093526 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -44,9 +44,7 @@ ERROR: bad-live-ranges interval ; dup vreg>> assign-spill-slot >>reload-from drop ; : split-and-spill ( live-interval n -- before after ) - split-for-spill - [ [ assign-spill ] [ assign-reload ] bi* ] - [ [ t >>record-spill? ] [ t >>record-reload? ] bi* ] 2bi ; + split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ; : find-use-position ( live-interval new -- n ) [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ; @@ -80,7 +78,6 @@ ERROR: bad-live-ranges interval ; { [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ; : split-live-out ( live-interval -- ) - f >>record-spill? { [ trim-before-ranges ] [ compute-start/end ] @@ -89,11 +86,10 @@ ERROR: bad-live-ranges interval ; } cleave ; : split-live-in ( live-interval -- ) - f >>record-reload? { [ trim-after-ranges ] [ compute-start/end ] - ! [ assign-reload ] + [ assign-reload ] [ add-handled ] } cleave ; 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 e735640b10..bf7e8bc042 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -11,7 +11,7 @@ C: live-range TUPLE: live-interval vreg -reg spill-to record-spill? reload-from record-reload? +reg spill-to reload-from split-before split-after split-next start end ranges uses copy-from ; From 1a190ae97eca3e8b0b0c0c142521c76a807b353c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 03:49:10 -0500 Subject: [PATCH 23/28] Remove A+s shortcut for saving image in UI --- basis/ui/tools/tools.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor index 7ea34e651f..42bc0ef1f2 100644 --- a/basis/ui/tools/tools.factor +++ b/basis/ui/tools/tools.factor @@ -26,7 +26,6 @@ tool "tool-switching" f { } define-command-map tool "common" f { - { T{ key-down f { A+ } "s" } save } { T{ key-down f { A+ } "w" } close-window } { T{ key-down f { A+ } "q" } com-exit } { T{ key-down f f "F2" } refresh-all } From 6737d2cdabf04981bd779a796eccf93b19d92447 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 12:20:43 -0500 Subject: [PATCH 24/28] benchmark.hashtables: throw something together --- extra/benchmark/hashtables/authors.txt | 1 + extra/benchmark/hashtables/hashtables.factor | 75 ++++++++++++++++++++ 2 files changed, 76 insertions(+) create mode 100644 extra/benchmark/hashtables/authors.txt create mode 100644 extra/benchmark/hashtables/hashtables.factor diff --git a/extra/benchmark/hashtables/authors.txt b/extra/benchmark/hashtables/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/hashtables/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/hashtables/hashtables.factor b/extra/benchmark/hashtables/hashtables.factor new file mode 100644 index 0000000000..065ad9c34a --- /dev/null +++ b/extra/benchmark/hashtables/hashtables.factor @@ -0,0 +1,75 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs combinators kernel locals math +math.ranges memoize sequences strings hashtables +math.parser grouping ; +IN: benchmark.hashtables + +MEMO: strings ( -- str ) + 1 100 [a,b] 1 [ + ] accumulate nip [ number>string ] map ; + +:: add-delete-mix ( hash keys -- ) + keys [| k | + 0 k hash set-at + k hash delete-at + ] each + + keys [ + 0 swap hash set-at + ] each + + keys [ + hash delete-at + ] each ; + +:: store-lookup-mix ( hash keys -- ) + keys [ + 0 swap hash set-at + ] each + + keys [ + hash at + ] map drop + + keys [ + hash [ 1 + ] change-at + ] each ; + +: string-mix ( hash -- ) + strings + [ add-delete-mix ] + [ store-lookup-mix ] + 2bi ; + +TUPLE: collision value ; + +M: collision hashcode* value>> hashcode* 15 bitand ; + +: collision-mix ( hash -- ) + strings 30 head [ collision boa ] map + [ add-delete-mix ] + [ store-lookup-mix ] + 2bi ; + +: small-mix ( hash -- ) + strings 10 group [ + [ add-delete-mix ] + [ store-lookup-mix ] + 2bi + ] with each ; + +: hashtable-benchmark ( -- ) + H{ } clone + 10000 [ + dup { + [ small-mix ] + [ clear-assoc ] + [ string-mix ] + [ clear-assoc ] + [ collision-mix ] + [ clear-assoc ] + } cleave + ] times + drop ; + +MAIN: hashtable-benchmark \ No newline at end of file From 516ce0c71de7e5a8bd64a255b2f39d208a9353f7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 13:00:58 -0500 Subject: [PATCH 25/28] threads: better error messages --- basis/threads/threads.factor | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index cacc628e2a..dec44625f7 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -43,13 +43,15 @@ sleep-entry ; : thread-registered? ( thread -- ? ) id>> threads key? ; +ERROR: already-stopped thread ; + : check-unregistered ( thread -- thread ) - dup thread-registered? - [ "Thread already stopped" throw ] when ; + dup thread-registered? [ already-stopped ] when ; + +ERROR: not-running thread ; : check-registered ( thread -- thread ) - dup thread-registered? - [ "Thread is not running" throw ] unless ; + dup thread-registered? [ not-running ] unless ; Date: Tue, 7 Jul 2009 13:01:27 -0500 Subject: [PATCH 26/28] compiler.cfg.linear-scan: debugging spilling, add more assertions --- .../allocation/spilling/spilling.factor | 10 +- .../linear-scan/allocation/state/state.factor | 27 ++- .../linear-scan/assignment/assignment.factor | 17 +- .../cfg/linear-scan/linear-scan-tests.factor | 204 +++++++++++++++++- .../cfg/linear-scan/linear-scan.factor | 3 +- .../linear-scan/numbering/numbering.factor | 15 +- 6 files changed, 251 insertions(+), 25 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 1bd7093526..9949832294 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -72,7 +72,13 @@ ERROR: bad-live-ranges interval ; [ uses>> first ] [ second ] bi* > ; : spill-new ( new pair -- ) - "not sure what to do yet" throw ; + drop + { + [ trim-after-ranges ] + [ compute-start/end ] + [ assign-reload ] + [ add-unhandled ] + } cleave ; : split-intersecting? ( live-interval new reg -- ? ) { [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ; @@ -90,7 +96,7 @@ ERROR: bad-live-ranges interval ; [ trim-after-ranges ] [ compute-start/end ] [ assign-reload ] - [ add-handled ] + [ add-unhandled ] } cleave ; : (split-intersecting) ( live-interval new -- ) diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor index a08e3e37bd..3e646b40f0 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -5,6 +5,20 @@ kernel math math.order namespaces sequences vectors compiler.cfg.linear-scan.live-intervals ; IN: compiler.cfg.linear-scan.allocation.state +! Start index of current live interval. We ensure that all +! live intervals added to the unhandled set have a start index +! strictly greater than this one. This ensures that we can catch +! infinite loop situations. We also ensure that all live +! intervals added to the handled set have an end index strictly +! smaller than this one. This helps catch bugs. +SYMBOL: progress + +: check-unhandled ( live-interval -- ) + start>> progress get <= [ "check-unhandled" throw ] when ; inline + +: check-handled ( live-interval -- ) + end>> progress get > [ "check-handled" throw ] when ; inline + ! Mapping from register classes to sequences of machine registers SYMBOL: registers @@ -39,7 +53,7 @@ SYMBOL: inactive-intervals SYMBOL: handled-intervals : add-handled ( live-interval -- ) - handled-intervals get push ; + [ check-handled ] [ handled-intervals get push ] bi ; : finished? ( n live-interval -- ? ) end>> swap < ; @@ -93,17 +107,8 @@ ERROR: register-already-used live-interval ; ! Minheap of live intervals which still need a register allocation SYMBOL: unhandled-intervals -! Start index of current live interval. We ensure that all -! live intervals added to the unhandled set have a start index -! strictly greater than ths one. This ensures that we can catch -! infinite loop situations. -SYMBOL: progress - -: check-progress ( live-interval -- ) - start>> progress get <= [ "No progress" throw ] when ; inline - : add-unhandled ( live-interval -- ) - [ check-progress ] + [ check-unhandled ] [ dup start>> unhandled-intervals get heap-push ] bi ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index bc565c6cbb..c995569c2e 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -68,8 +68,7 @@ SYMBOL: register-live-outs } cleave f swap \ _copy boa , ; : handle-copy ( live-interval -- ) - dup [ spill-to>> not ] [ split-next>> ] bi and - [ insert-copy ] [ drop ] if ; + dup split-next>> [ insert-copy ] [ drop ] if ; : expire-old-intervals ( n -- ) [ pending-intervals get ] dip '[ @@ -82,7 +81,7 @@ SYMBOL: register-live-outs [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] - [ end>> ] + [ start>> ] } cleave f swap \ _reload boa , ; : handle-reload ( live-interval -- ) @@ -92,7 +91,7 @@ SYMBOL: register-live-outs #! Any live intervals which start on the current instruction #! are added to the active set. unhandled-intervals get dup heap-empty? [ 2drop ] [ - 2dup heap-peek drop start>> >= [ + 2dup heap-peek drop start>> = [ heap-pop drop [ add-active ] [ handle-reload ] bi activate-new-intervals @@ -179,10 +178,12 @@ ERROR: bad-vreg vreg ; [ bb begin-block [ - [ insn#>> prepare-insn ] - [ assign-registers-in-insn ] - [ , ] - tri + { + [ insn#>> 1 - prepare-insn ] + [ insn#>> prepare-insn ] + [ assign-registers-in-insn ] + [ , ] + } cleave ] each bb end-block ] V{ } make diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 59e6190b63..b5999838ca 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -1,7 +1,7 @@ IN: compiler.cfg.linear-scan.tests USING: tools.test random sorting sequences sets hashtables assocs kernel fry arrays splitting namespaces math accessors vectors locals -math.order grouping +math.order grouping strings strings.private cpu.architecture compiler.cfg compiler.cfg.optimizer @@ -13,6 +13,7 @@ compiler.cfg.rpo compiler.cfg.linearization compiler.cfg.debugger compiler.cfg.linear-scan +compiler.cfg.linear-scan.numbering compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state @@ -24,6 +25,7 @@ FROM: compiler.cfg.linear-scan.assignment => check-assignment? ; check-allocation? on check-assignment? on +check-numbering? on [ { T{ live-range f 1 10 } T{ live-range f 15 15 } } @@ -2332,4 +2334,204 @@ V{ 4 get 6 get 1vector >>successors drop 5 get 6 get 1vector >>successors drop +[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test + +! Another push-all reduction to demonstrate numbering anamoly +V{ T{ ##prologue } T{ ##branch } } +0 test-bb + +V{ + T{ ##peek { dst V int-regs 1 } { loc D 0 } } + T{ ##slot-imm + { dst V int-regs 5 } + { obj V int-regs 1 } + { slot 3 } + { tag 7 } + } + T{ ##peek { dst V int-regs 7 } { loc D 1 } } + T{ ##slot-imm + { dst V int-regs 12 } + { obj V int-regs 7 } + { slot 1 } + { tag 6 } + } + T{ ##add + { dst V int-regs 25 } + { src1 V int-regs 5 } + { src2 V int-regs 12 } + } + T{ ##compare-branch + { src1 V int-regs 25 } + { src2 V int-regs 5 } + { cc cc> } + } +} +1 test-bb + +V{ + T{ ##slot-imm + { dst V int-regs 41 } + { obj V int-regs 1 } + { slot 2 } + { tag 7 } + } + T{ ##slot-imm + { dst V int-regs 44 } + { obj V int-regs 41 } + { slot 1 } + { tag 6 } + } + T{ ##compare-branch + { src1 V int-regs 25 } + { src2 V int-regs 44 } + { cc cc> } + } +} +2 test-bb + +V{ + T{ ##add-imm + { dst V int-regs 54 } + { src1 V int-regs 25 } + { src2 8 } + } + T{ ##load-immediate { dst V int-regs 55 } { val 24 } } + T{ ##inc-d { n 4 } } + T{ ##inc-r { n 1 } } + T{ ##replace { src V int-regs 25 } { loc D 2 } } + T{ ##replace { src V int-regs 1 } { loc D 3 } } + T{ ##replace { src V int-regs 5 } { loc D 4 } } + T{ ##replace { src V int-regs 1 } { loc D 1 } } + T{ ##replace { src V int-regs 54 } { loc D 0 } } + T{ ##replace { src V int-regs 12 } { loc R 0 } } + T{ ##fixnum-mul + { src1 V int-regs 54 } + { src2 V int-regs 55 } + { temp1 V int-regs 58 } + { temp2 V int-regs 59 } + } + T{ ##branch } +} +3 test-bb + +V{ + T{ ##peek { dst V int-regs 60 } { loc D 1 } } + T{ ##slot-imm + { dst V int-regs 66 } + { obj V int-regs 60 } + { slot 2 } + { tag 7 } + } + T{ ##inc-d { n 1 } } + T{ ##inc-r { n 1 } } + T{ ##replace { src V int-regs 66 } { loc D 0 } } + T{ ##replace { src V int-regs 60 } { loc R 0 } } + T{ ##call { word resize-string } } + T{ ##branch } +} +4 test-bb + +V{ + T{ ##peek { dst V int-regs 67 } { loc R 0 } } + T{ ##peek { dst V int-regs 68 } { loc D 0 } } + T{ ##set-slot-imm + { src V int-regs 68 } + { obj V int-regs 67 } + { slot 2 } + { tag 7 } + } + T{ ##write-barrier + { src V int-regs 67 } + { card# V int-regs 75 } + { table V int-regs 76 } + } + T{ ##inc-d { n -1 } } + T{ ##inc-r { n -1 } } + T{ ##peek { dst V int-regs 94 } { loc D 0 } } + T{ ##peek { dst V int-regs 96 } { loc D 1 } } + T{ ##peek { dst V int-regs 98 } { loc D 2 } } + T{ ##peek { dst V int-regs 100 } { loc D 3 } } + T{ ##peek { dst V int-regs 102 } { loc D 4 } } + T{ ##peek { dst V int-regs 106 } { loc R 0 } } + T{ ##copy { dst V int-regs 95 } { src V int-regs 94 } } + T{ ##copy { dst V int-regs 97 } { src V int-regs 96 } } + T{ ##copy { dst V int-regs 99 } { src V int-regs 98 } } + T{ ##copy { dst V int-regs 101 } { src V int-regs 100 } } + T{ ##copy { dst V int-regs 103 } { src V int-regs 102 } } + T{ ##copy { dst V int-regs 107 } { src V int-regs 106 } } + T{ ##branch } +} +5 test-bb + +V{ + T{ ##inc-d { n 3 } } + T{ ##inc-r { n 1 } } + T{ ##copy { dst V int-regs 95 } { src V int-regs 1 } } + T{ ##copy { dst V int-regs 97 } { src V int-regs 25 } } + T{ ##copy { dst V int-regs 99 } { src V int-regs 1 } } + T{ ##copy { dst V int-regs 101 } { src V int-regs 5 } } + T{ ##copy { dst V int-regs 103 } { src V int-regs 7 } } + T{ ##copy { dst V int-regs 107 } { src V int-regs 12 } } + T{ ##branch } +} +6 test-bb + +V{ + T{ ##load-immediate + { dst V int-regs 78 } + { val 4611686018427387896 } + } + T{ ##and + { dst V int-regs 81 } + { src1 V int-regs 97 } + { src2 V int-regs 78 } + } + T{ ##set-slot-imm + { src V int-regs 81 } + { obj V int-regs 95 } + { slot 3 } + { tag 7 } + } + T{ ##inc-d { n -2 } } + T{ ##copy { dst V int-regs 110 } { src V int-regs 99 } } + T{ ##copy { dst V int-regs 111 } { src V int-regs 101 } } + T{ ##copy { dst V int-regs 112 } { src V int-regs 103 } } + T{ ##copy { dst V int-regs 117 } { src V int-regs 107 } } + T{ ##branch } +} +7 test-bb + +V{ + T{ ##inc-d { n 1 } } + T{ ##inc-r { n 1 } } + T{ ##copy { dst V int-regs 110 } { src V int-regs 1 } } + T{ ##copy { dst V int-regs 111 } { src V int-regs 5 } } + T{ ##copy { dst V int-regs 112 } { src V int-regs 7 } } + T{ ##copy { dst V int-regs 117 } { src V int-regs 12 } } + T{ ##branch } +} +8 test-bb + +V{ + T{ ##inc-d { n 1 } } + T{ ##inc-r { n -1 } } + T{ ##replace { src V int-regs 117 } { loc D 0 } } + T{ ##replace { src V int-regs 110 } { loc D 1 } } + T{ ##replace { src V int-regs 111 } { loc D 2 } } + T{ ##replace { src V int-regs 112 } { loc D 3 } } + T{ ##epilogue } + T{ ##return } +} +9 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 8 get V{ } 2sequence >>successors drop +2 get 3 get 6 get V{ } 2sequence >>successors drop +3 get 4 get 1vector >>successors drop +4 get 5 get 1vector >>successors drop +5 get 7 get 1vector >>successors drop +6 get 7 get 1vector >>successors drop +7 get 9 get 1vector >>successors drop +8 get 9 get 1vector >>successors drop + [ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index 2d3ad41b22..9013389cc9 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -31,7 +31,8 @@ IN: compiler.cfg.linear-scan rpo number-instructions rpo compute-live-intervals machine-registers allocate-registers rpo assign-registers - rpo resolve-data-flow ; + rpo resolve-data-flow + rpo check-numbering ; : linear-scan ( cfg -- cfg' ) [ diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor index 6734f6a359..ac18b0cb2e 100644 --- a/basis/compiler/cfg/linear-scan/numbering/numbering.factor +++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors math sequences ; +USING: kernel accessors math sequences grouping namespaces ; IN: compiler.cfg.linear-scan.numbering : number-instructions ( rpo -- ) @@ -8,4 +8,15 @@ IN: compiler.cfg.linear-scan.numbering instructions>> [ [ (>>insn#) ] [ drop 2 + ] 2bi ] each - ] each drop ; \ No newline at end of file + ] each drop ; + +SYMBOL: check-numbering? + +ERROR: bad-numbering bb ; + +: check-block-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 From c171527b8de91a42eb65db842cc9f47e36f84c6f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 14:34:08 -0500 Subject: [PATCH 27/28] Add vectors.functor for generating vector types from arrays; re-implement bit-vectors and specialized-vectors using this. Add DEFERS directive to functors --- basis/bit-vectors/bit-vectors-docs.factor | 4 +-- basis/bit-vectors/bit-vectors.factor | 28 ++-------------- basis/functors/functors.factor | 2 ++ .../functor/functor.factor | 26 ++++----------- basis/vectors/functor/functor.factor | 33 +++++++++++++++++++ 5 files changed, 45 insertions(+), 48 deletions(-) create mode 100644 basis/vectors/functor/functor.factor diff --git a/basis/bit-vectors/bit-vectors-docs.factor b/basis/bit-vectors/bit-vectors-docs.factor index f0e4e47586..66d3d603fe 100644 --- a/basis/bit-vectors/bit-vectors-docs.factor +++ b/basis/bit-vectors/bit-vectors-docs.factor @@ -22,11 +22,11 @@ HELP: bit-vector { $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ; HELP: -{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } } +{ $values { "capacity" "a positive integer specifying initial capacity" } { "vector" bit-vector } } { $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ; HELP: >bit-vector -{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } } +{ $values { "seq" "a sequence" } { "vector" bit-vector } } { $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ; HELP: ?V{ diff --git a/basis/bit-vectors/bit-vectors.factor b/basis/bit-vectors/bit-vectors.factor index a238f61244..cdfe48b164 100644 --- a/basis/bit-vectors/bit-vectors.factor +++ b/basis/bit-vectors/bit-vectors.factor @@ -2,34 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences sequences.private growable bit-arrays prettyprint.custom -parser accessors ; +parser accessors vectors.functor classes.parser ; IN: bit-vectors -TUPLE: bit-vector -{ underlying bit-array initial: ?{ } } -{ length array-capacity } ; - -: ( n -- bit-vector ) - 0 bit-vector boa ; inline - -: >bit-vector ( seq -- bit-vector ) - T{ bit-vector f ?{ } 0 } clone-like ; - -M: bit-vector like - drop dup bit-vector? [ - dup bit-array? - [ dup length bit-vector boa ] [ >bit-vector ] if - ] unless ; - -M: bit-vector new-sequence - drop [ ] [ >fixnum ] bi bit-vector boa ; - -M: bit-vector equal? - over bit-vector? [ sequence= ] [ 2drop f ] if ; - -M: bit-array new-resizable drop ; - -INSTANCE: bit-vector growable +<< "bit-vector" create-class-in \ bit-array \ define-vector >> SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ; diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index b7dab0d6af..6ffc4d8112 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -121,6 +121,8 @@ PRIVATE> SYNTAX: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; +SYNTAX: DEFERS [ current-vocab create ] (INTERPOLATE) ; + SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ; SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 412e5b4689..e4534e5948 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -1,37 +1,23 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: functors sequences sequences.private growable prettyprint.custom kernel words classes math parser ; +QUALIFIED: vectors.functor IN: specialized-vectors.functor FUNCTOR: define-vector ( T -- ) +V DEFINES-CLASS ${T}-vector + A IS ${T}-array IS <${A}> -V DEFINES-CLASS ${T}-vector - DEFINES <${V}> ->V DEFINES >${V} +>V DEFERS >${V} V{ DEFINES ${V}{ WHERE -TUPLE: V { underlying A } { length array-capacity } ; - -: ( capacity -- vector ) 0 V boa ; inline - -M: V like - drop dup V instance? [ - dup A instance? [ dup length V boa ] [ >V ] if - ] unless ; - -M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; - -M: A new-resizable drop ; - -M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; - -: >V ( seq -- vector ) V new clone-like ; inline +V A vectors.functor:define-vector M: V pprint-delims drop \ V{ \ } ; diff --git a/basis/vectors/functor/functor.factor b/basis/vectors/functor/functor.factor new file mode 100644 index 0000000000..47a6c2090a --- /dev/null +++ b/basis/vectors/functor/functor.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: functors sequences sequences.private growable +kernel words classes math parser ; +IN: vectors.functor + +FUNCTOR: define-vector ( V A -- ) + + DEFINES <${V}> +>V DEFINES >${V} + +WHERE + +TUPLE: V { underlying A } { length array-capacity } ; + +: ( capacity -- vector ) 0 V boa ; inline + +M: V like + drop dup V instance? [ + dup A instance? [ dup length V boa ] [ >V ] if + ] unless ; + +M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; + +M: A new-resizable drop ; + +M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; + +: >V ( seq -- vector ) V new clone-like ; inline + +INSTANCE: V growable + +;FUNCTOR From dafdbe13c914884122d42a0c389fc4741ced334a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 15:01:30 -0500 Subject: [PATCH 28/28] growable vocabulary: make 'contract' generic so that only real vectors clear popped elements; add resize method for struct-arrays, add new struct-vectors vocabulary --- basis/bit-vectors/bit-vectors.factor | 3 ++- .../functor/functor.factor | 2 ++ .../struct-arrays/struct-arrays-tests.factor | 4 +++- basis/struct-arrays/struct-arrays.factor | 4 ++++ .../struct-vectors/struct-vectors-docs.factor | 16 +++++++++++++ .../struct-vectors-tests.factor | 20 ++++++++++++++++ basis/struct-vectors/struct-vectors.factor | 23 +++++++++++++++++++ core/byte-vectors/byte-vectors.factor | 2 ++ core/growable/growable.factor | 8 ++++--- 9 files changed, 77 insertions(+), 5 deletions(-) create mode 100644 basis/struct-vectors/struct-vectors-docs.factor create mode 100644 basis/struct-vectors/struct-vectors-tests.factor create mode 100644 basis/struct-vectors/struct-vectors.factor diff --git a/basis/bit-vectors/bit-vectors.factor b/basis/bit-vectors/bit-vectors.factor index cdfe48b164..7febe6fc1b 100644 --- a/basis/bit-vectors/bit-vectors.factor +++ b/basis/bit-vectors/bit-vectors.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences sequences.private growable bit-arrays prettyprint.custom @@ -9,6 +9,7 @@ IN: bit-vectors SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ; +M: bit-vector contract 2drop ; M: bit-vector >pprint-sequence ; M: bit-vector pprint-delims drop \ ?V{ \ } ; M: bit-vector pprint* pprint-object ; diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index e4534e5948..6635fbeaf2 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -19,6 +19,8 @@ WHERE V A vectors.functor:define-vector +M: V contract 2drop ; + M: V pprint-delims drop \ V{ \ } ; M: V >pprint-sequence ; diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor index 8ce45ccc15..7347b94628 100755 --- a/basis/struct-arrays/struct-arrays-tests.factor +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -35,4 +35,6 @@ C-STRUCT: test-struct 10 "test-struct" malloc-struct-array &free drop ] with-destructors -] unit-test \ No newline at end of file +] unit-test + +[ 15 ] [ 15 10 "point" resize length ] unit-test \ No newline at end of file diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor index 5aaf2c2ea6..a033de5e14 100755 --- a/basis/struct-arrays/struct-arrays.factor +++ b/basis/struct-arrays/struct-arrays.factor @@ -20,6 +20,10 @@ M: struct-array set-nth-unsafe M: struct-array new-sequence element-size>> [ * ] 2keep struct-array boa ; inline +M: struct-array resize ( n seq -- newseq ) + [ [ element-size>> * ] [ underlying>> ] bi resize ] [ element-size>> ] 2bi + struct-array boa ; + : ( length c-type -- struct-array ) heap-size [ * ] 2keep struct-array boa ; inline diff --git a/basis/struct-vectors/struct-vectors-docs.factor b/basis/struct-vectors/struct-vectors-docs.factor new file mode 100644 index 0000000000..368b054565 --- /dev/null +++ b/basis/struct-vectors/struct-vectors-docs.factor @@ -0,0 +1,16 @@ +IN: struct-vectors +USING: help.markup help.syntax alien strings math ; + +HELP: struct-vector +{ $class-description "The class of growable C struct and union arrays." } ; + +HELP: +{ $values { "capacity" integer } { "c-type" string } { "struct-vector" struct-vector } } +{ $description "Creates a new vector with the given initial capacity." } ; + +ARTICLE: "struct-vectors" "C struct and union vectors" +"The " { $vocab-link "struct-vectors" } " vocabulary implements vectors specialized for holding C struct and union values. These are growable versions of " { $vocab-link "struct-arrays" } "." +{ $subsection struct-vector } +{ $subsection } ; + +ABOUT: "struct-vectors" diff --git a/basis/struct-vectors/struct-vectors-tests.factor b/basis/struct-vectors/struct-vectors-tests.factor new file mode 100644 index 0000000000..cff65d3371 --- /dev/null +++ b/basis/struct-vectors/struct-vectors-tests.factor @@ -0,0 +1,20 @@ +IN: struct-vectors.tests +USING: struct-vectors tools.test alien.c-types kernel sequences ; + +C-STRUCT: point + { "float" "x" } + { "float" "y" } ; + +: make-point ( x y -- point ) + "point" + [ set-point-y ] keep + [ set-point-x ] keep ; + +[ ] [ 1 "point" "v" set ] unit-test + +[ 1.5 6.0 ] [ + 1.0 2.0 make-point "v" get push + 3.0 4.5 make-point "v" get push + 1.5 6.0 make-point "v" get push + "v" get pop [ point-x ] [ point-y ] bi +] unit-test \ No newline at end of file diff --git a/basis/struct-vectors/struct-vectors.factor b/basis/struct-vectors/struct-vectors.factor new file mode 100644 index 0000000000..252a46d640 --- /dev/null +++ b/basis/struct-vectors/struct-vectors.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors byte-arrays growable kernel math sequences +sequences.private struct-arrays ; +IN: struct-vectors + +TUPLE: struct-vector +{ underlying struct-array } +{ length array-capacity } +{ c-type read-only } ; + +: ( capacity c-type -- struct-vector ) + [ 0 ] keep struct-vector boa ; inline + +M: struct-vector new-sequence + [ c-type>> ] [ [ >fixnum ] [ c-type>> ] bi ] 2bi + struct-vector boa ; + +M: struct-vector contract 2drop ; + +M: struct-array new-resizable c-type>> ; + +INSTANCE: struct-vector growable \ No newline at end of file diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index c273cea867..fc3d9501c7 100644 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -26,6 +26,8 @@ M: byte-vector new-sequence M: byte-vector equal? over byte-vector? [ sequence= ] [ 2drop f ] if ; +M: byte-vector contract 2drop ; + M: byte-array like #! If we have an byte-array, we're done. #! If we have a byte-vector, and it's at full capacity, diff --git a/core/growable/growable.factor b/core/growable/growable.factor index 684aab1158..754a3293d1 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel kernel.private math math.private sequences sequences.private ; @@ -18,10 +18,12 @@ M: growable set-nth-unsafe underlying>> set-nth-unsafe ; : expand ( len seq -- ) [ resize ] change-underlying drop ; inline -: contract ( len seq -- ) +GENERIC: contract ( len seq -- ) + +M: growable contract ( len seq -- ) [ length ] keep [ [ 0 ] 2dip set-nth-unsafe ] curry - (each-integer) ; inline + (each-integer) ; : growable-check ( n seq -- n seq ) over 0 < [ bounds-error ] when ; inline