diff --git a/basis/alien/inline/compiler/compiler.factor b/basis/alien/inline/compiler/compiler.factor index b5a7861d6b..b1ccc2baab 100644 --- a/basis/alien/inline/compiler/compiler.factor +++ b/basis/alien/inline/compiler/compiler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators fry generalizations io.encodings.ascii io.files io.files.temp io.launcher kernel -locals sequences system ; +locals make sequences system vocabs.parser words ; IN: alien.inline.compiler SYMBOL: C @@ -15,37 +15,59 @@ SYMBOL: C++ { [ dup windows? ] [ drop ".dll" ] } } cond ; +: library-path ( str -- str' ) + '[ + "lib-" % current-vocab name>> % + "-" % _ % library-suffix % + ] "" make temp-file ; + : src-suffix ( lang -- str ) { { C [ ".c" ] } { C++ [ ".cpp" ] } } case ; -: compiler ( lang -- str ) +HOOK: compiler os ( lang -- str ) + +M: word compiler ( lang -- str ) { { C [ "gcc" ] } { C++ [ "g++" ] } } case ; +M: openbsd compiler ( lang -- str ) + { + { C [ "gcc" ] } + { C++ [ "eg++" ] } + } case ; + +HOOK: compiler-descr os ( lang -- descr ) + +M: word compiler-descr compiler 1array ; +M: macosx compiler-descr + call-next-method cpu x86.64? + [ { "-arch" "x86_64" } append ] when ; + +HOOK: link-descr os ( -- descr ) + +M: word link-descr { "-shared" "-o" } ; +M: macosx link-descr + { "-g" "-prebind" "-dynamiclib" "-o" } + cpu x86.64? [ { "-arch" "x86_64" } prepend ] when ; + : 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 ; + compiler-descr link-descr append 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 - { "-fPIC" "-c" "-o" } lang compiler prefix prepend + lang compiler-descr { "-fPIC" "-c" "-o" } append prepend try-process ; :: link-object ( lang args name -- ) - args name [ "lib" prepend library-suffix append ] - [ ".o" append ] bi [ temp-file ] bi@ 2array + args name [ library-path ] + [ ".o" append temp-file ] bi 2array lang link-command try-process ; :: compile-to-library ( lang args contents name -- ) diff --git a/basis/alien/inline/inline-tests.factor b/basis/alien/inline/inline-tests.factor new file mode 100644 index 0000000000..09b76a4bb5 --- /dev/null +++ b/basis/alien/inline/inline-tests.factor @@ -0,0 +1,72 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.inline alien.inline.private io.directories io.files +kernel namespaces tools.test alien.c-types alien.structs ; +IN: alien.inline.tests + +DELETE-C-LIBRARY: test +C-LIBRARY: test + +C-FUNCTION: const-int add ( int a, int b ) + return a + b; +; + +C-TYPEDEF: double bigfloat + +C-FUNCTION: bigfloat smaller ( bigfloat a ) + return a / 10; +; + +C-STRUCTURE: rectangle + { "int" "width" } + { "int" "height" } ; + +C-FUNCTION: int area ( rectangle c ) + return c.width * c.height; +; + +;C-LIBRARY + +{ 2 1 } [ add ] must-infer-as +[ 5 ] [ 2 3 add ] unit-test + +[ t ] [ "double" "bigfloat" [ resolve-typedef ] bi@ = ] unit-test +{ 1 1 } [ smaller ] must-infer-as +[ 1.0 ] [ 10 smaller ] unit-test + +[ t ] [ "rectangle" resolve-typedef struct-type? ] unit-test +{ 1 1 } [ area ] must-infer-as +[ 20 ] [ + "rectangle" + 4 over set-rectangle-width + 5 over set-rectangle-height + area +] unit-test + + +DELETE-C-LIBRARY: cpplib +C-LIBRARY: cpplib + +COMPILE-AS-C++ + +C-INCLUDE: + +C-FUNCTION: const-char* hello ( ) + std::string s("hello world"); + return s.c_str(); +; + +;C-LIBRARY + +{ 0 1 } [ hello ] must-infer-as +[ "hello world" ] [ hello ] unit-test + + +DELETE-C-LIBRARY: compile-error +C-LIBRARY: compile-error + +C-FUNCTION: char* breakme ( ) + return not a string; +; + +<< [ compile-c-library ] must-fail >> diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index ae4a95497a..88cc5e3519 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -2,10 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. 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 ; +generalizations grouping io.directories io.files +io.files.info io.files.temp kernel lexer math math.order +math.ranges multiline namespaces sequences source-files +splitting strings system vocabs.loader vocabs.parser words +alien.c-types alien.structs make parser ; IN: alien.inline > ] bi@ <=> +lt+ = + c-library get library-path dup exists? [ + file get [ + path>> + [ file-info modified>> ] bi@ <=> +lt+ = + ] [ drop t ] if* ] [ drop t ] if ; : compile-library ( -- ) @@ -66,7 +64,7 @@ PRIVATE> : compile-c-library ( -- ) compile-library? [ compile-library ] when - c-library get library-path "cdecl" add-library ; + c-library get dup library-path "cdecl" add-library ; : define-c-function ( function types effect -- ) [ factor-function define-declared ] 3keep prototype-string @@ -89,6 +87,25 @@ PRIVATE> : define-c-include ( str -- ) "#include " prepend c-strings get push ; +: define-c-typedef ( old new -- ) + [ typedef ] [ + [ swap "typedef " % % " " % % ";" % ] + "" make c-strings get push + ] 2bi ; + +: define-c-struct ( name vocab fields -- ) + [ define-struct ] [ + nip over + [ + "typedef struct " % "_" % % " {\n" % + [ first2 swap % " " % % ";\n" % ] each + "} " % % ";\n" % + ] "" make c-strings get push + ] 3bi ; + +: delete-inline-library ( str -- ) + library-path dup exists? [ delete-file ] [ drop ] if ; + SYNTAX: C-LIBRARY: scan define-c-library ; SYNTAX: COMPILE-AS-C++ t library-is-c++ set ; @@ -104,4 +121,14 @@ SYNTAX: C-INCLUDE: scan define-c-include ; SYNTAX: C-FUNCTION: function-types-effect define-c-function ; +SYNTAX: C-TYPEDEF: scan scan define-c-typedef ; + +SYNTAX: C-STRUCTURE: + scan current-vocab parse-definition define-c-struct ; + SYNTAX: ;C-LIBRARY compile-c-library ; + +SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ; + +SYNTAX: RAW-C: + [ "\n" % parse-here % "\n" % c-strings get push ] "" make ; diff --git a/basis/alien/inline/tests/tests.factor b/basis/alien/inline/tests/tests.factor deleted file mode 100644 index acd2d615cd..0000000000 --- a/basis/alien/inline/tests/tests.factor +++ /dev/null @@ -1,48 +0,0 @@ -! Copyright (C) 2009 Jeremy Hughes. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test alien.inline alien.inline.private io.files -io.directories kernel ; -IN: alien.inline.tests - -C-LIBRARY: const - -C-FUNCTION: const-int add ( int a, int b ) - return a + b; -; - -;C-LIBRARY - -{ 2 1 } [ add ] must-infer-as -[ 5 ] [ 2 3 add ] unit-test - -<< library-path dup exists? [ delete-file ] [ drop ] if >> - - -C-LIBRARY: cpplib - -COMPILE-AS-C++ - -C-INCLUDE: - -C-FUNCTION: const-char* hello ( ) - std::string s("hello world"); - return s.c_str(); -; - -;C-LIBRARY - -{ 0 1 } [ hello ] must-infer-as -[ "hello world" ] [ hello ] unit-test - -<< library-path dup exists? [ delete-file ] [ drop ] if >> - - -C-LIBRARY: compile-error - -C-FUNCTION: char* breakme ( ) - return not a string; -; - -<< [ compile-c-library ] must-fail >> - -<< library-path dup exists? [ delete-file ] [ drop ] if >> 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..7febe6fc1b 100644 --- a/basis/bit-vectors/bit-vectors.factor +++ b/basis/bit-vectors/bit-vectors.factor @@ -1,38 +1,15 @@ -! 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 -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 ; +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/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 7dd3977605..c197da9814 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -28,16 +28,30 @@ IN: compiler.cfg.linear-scan.allocation : no-free-registers? ( result -- ? ) second 0 = ; inline +: split-to-fit ( new n -- before after ) + split-interval + [ [ compute-start/end ] bi@ ] + [ >>split-next drop ] + [ ] + 2tri ; + : register-partially-available ( new result -- ) - [ second split-before-use ] keep - '[ _ register-available ] [ add-unhandled ] bi* ; + { + { [ 2dup second 1 - spill-live-out? ] [ drop spill-live-out ] } + { [ 2dup second 1 - spill-live-in? ] [ drop spill-live-in ] } + [ + [ second 1 - split-to-fit ] keep + '[ _ register-available ] [ add-unhandled ] bi* + ] + } cond ; : assign-register ( new -- ) dup coalesce? [ coalesce ] [ dup register-status { { [ dup no-free-registers? ] [ drop assign-blocked-register ] } { [ 2dup register-available? ] [ register-available ] } - [ register-partially-available ] + ! [ register-partially-available ] + [ drop assign-blocked-register ] } cond ] if ; diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 9949832294..b89c1f4de2 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -38,7 +38,7 @@ ERROR: bad-live-ranges interval ; } 2cleave ; : assign-spill ( live-interval -- ) - dup vreg>> assign-spill-slot >>spill-to drop ; + dup vreg>> assign-spill-slot >>spill-to f >>split-next drop ; : assign-reload ( live-interval -- ) dup vreg>> assign-spill-slot >>reload-from drop ; @@ -80,10 +80,12 @@ ERROR: bad-live-ranges interval ; [ add-unhandled ] } cleave ; -: split-intersecting? ( live-interval new reg -- ? ) - { [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ; +: spill-live-out? ( live-interval n -- ? ) [ uses>> last ] dip < ; -: split-live-out ( live-interval -- ) +: spill-live-out ( live-interval -- ) + ! The interval has no more usages after the spill location. This + ! means it is the first child of an interval that was split. We + ! spill the value and let the resolve pass insert a reload later. { [ trim-before-ranges ] [ compute-start/end ] @@ -91,7 +93,13 @@ ERROR: bad-live-ranges interval ; [ add-handled ] } cleave ; -: split-live-in ( live-interval -- ) +: spill-live-in? ( live-interval n -- ? ) [ uses>> first ] dip > ; + +: spill-live-in ( live-interval -- ) + ! The interval does not have any usages before the spill location. + ! This means it is the second child of an interval that was + ! split. We reload the value and let the resolve pass insert a + ! split later. { [ trim-after-ranges ] [ compute-start/end ] @@ -99,40 +107,48 @@ ERROR: bad-live-ranges interval ; [ add-unhandled ] } cleave ; -: (split-intersecting) ( live-interval new -- ) - start>> { - { [ 2dup [ uses>> last ] dip < ] [ drop split-live-out ] } - { [ 2dup [ uses>> first ] dip > ] [ drop split-live-in ] } +: spill ( live-interval n -- ) + { + { [ 2dup spill-live-out? ] [ drop spill-live-out ] } + { [ 2dup spill-live-in? ] [ drop spill-live-in ] } [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] } cond ; -: (split-intersecting-active) ( active new -- ) - [ drop delete-active ] - [ (split-intersecting) ] 2bi ; +:: spill-intersecting-active ( new reg -- ) + ! If there is an active interval using 'reg' (there should be at + ! most one) are split and spilled and removed from the inactive + ! set. + new vreg>> active-intervals-for [ [ reg>> reg = ] find swap dup ] keep + '[ _ delete-nth new start>> spill ] [ 2drop ] if ; -: split-intersecting-active ( new reg -- ) - [ [ vreg>> active-intervals-for ] keep ] dip - [ '[ _ _ split-intersecting? ] filter ] 2keep drop - '[ _ (split-intersecting-active) ] each ; +:: spill-intersecting-inactive ( new reg -- ) + ! Any inactive intervals using 'reg' are split and spilled + ! and removed from the inactive set. + new vreg>> inactive-intervals-for [ + dup reg>> reg = [ + dup new intervals-intersect? [ + new start>> spill f + ] [ drop t ] if + ] [ drop t ] if + ] filter-here ; -: (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 ] +: spill-intersecting ( new reg -- ) + ! Split and spill all active and inactive intervals + ! which intersect 'new' and use 'reg'. + [ spill-intersecting-active ] + [ spill-intersecting-inactive ] 2bi ; : spill-available ( new pair -- ) - [ first split-intersecting ] [ register-available ] 2bi ; + ! A register would become fully available if all + ! active and inactive intervals using it were split + ! and spilled. + [ first spill-intersecting ] [ register-available ] 2bi ; : spill-partially-available ( new pair -- ) + ! A register would be available for part of the new + ! interval's lifetime if all active and inactive intervals + ! using that register were split and spilled. [ second 1 - split-and-spill add-unhandled ] keep spill-available ; diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index 71d3d56285..0a67710bc8 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -61,23 +61,3 @@ ERROR: splitting-atomic-interval ; after split-after ; HINTS: split-interval live-interval object ; - -: split-between-blocks ( new n -- before after ) - split-interval - 2dup [ compute-start/end ] bi@ ; - -: insert-use-for-copy ( seq n -- seq' ) - [ '[ _ < ] filter ] - [ nip dup 1 + 2array ] - [ 1 + '[ _ > ] filter ] - 2tri 3append ; - -: split-before-use ( new n -- before after ) - 1 - - 2dup swap covers? [ - [ '[ _ insert-use-for-copy ] change-uses ] keep - split-between-blocks - 2dup >>split-next drop - ] [ - split-between-blocks - ] if ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index c995569c2e..143e84aaf4 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -8,6 +8,7 @@ compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.registers compiler.cfg.instructions +compiler.cfg.linear-scan.mapping compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.live-intervals ; @@ -42,16 +43,11 @@ SYMBOL: register-live-outs H{ } clone register-live-outs set init-unhandled ; -: insert-spill ( live-interval -- ) - { - [ reg>> ] - [ vreg>> reg-class>> ] - [ spill-to>> ] - [ end>> ] - } cleave f swap \ _spill boa , ; - : handle-spill ( live-interval -- ) - dup spill-to>> [ insert-spill ] [ drop ] if ; + dup spill-to>> [ + [ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri + register->memory + ] [ drop ] if ; : first-split ( live-interval -- live-interval' ) dup split-before>> [ first-split ] [ ] ?if ; @@ -59,22 +55,19 @@ SYMBOL: register-live-outs : next-interval ( live-interval -- live-interval' ) split-next>> first-split ; -: insert-copy ( live-interval -- ) - { - [ next-interval reg>> ] - [ reg>> ] - [ vreg>> reg-class>> ] - [ end>> ] - } cleave f swap \ _copy boa , ; - : handle-copy ( live-interval -- ) - dup split-next>> [ insert-copy ] [ drop ] if ; + dup split-next>> [ + [ reg>> ] [ next-interval reg>> ] [ vreg>> reg-class>> ] tri + register->register + ] [ drop ] if ; : expire-old-intervals ( n -- ) - [ pending-intervals get ] dip '[ - dup end>> _ < - [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if - ] filter-here ; + [ + [ pending-intervals get ] dip '[ + dup end>> _ < + [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if + ] filter-here + ] { } make mapping-instructions % ; : insert-reload ( live-interval -- ) { diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index b5999838ca..06817071d4 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 strings strings.private +math.order grouping strings strings.private classes cpu.architecture compiler.cfg compiler.cfg.optimizer @@ -153,56 +153,6 @@ check-numbering? on } 10 split-for-spill [ 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 5 } - { uses V{ 5 } } - { ranges V{ T{ live-range f 5 5 } } } - } -] [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 0 } - { end 5 } - { uses V{ 0 1 5 } } - { ranges V{ T{ live-range f 0 5 } } } - } 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 } } } @@ -225,7 +175,7 @@ check-numbering? on { 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@ + } 4 split-to-fit [ f >>split-next ] bi@ ] unit-test [ @@ -1847,8 +1797,6 @@ test-diamond [ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test -USING: classes ; - [ ] [ 1 get instructions>> first regs>> V int-regs 0 swap at 2 get instructions>> first regs>> V int-regs 1 swap at assert= diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index 9013389cc9..77d66c274d 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -10,7 +10,8 @@ compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.assignment -compiler.cfg.linear-scan.resolve ; +compiler.cfg.linear-scan.resolve +compiler.cfg.linear-scan.mapping ; IN: compiler.cfg.linear-scan ! References: @@ -36,6 +37,7 @@ IN: compiler.cfg.linear-scan : linear-scan ( cfg -- cfg' ) [ + init-mapping dup reverse-post-order machine-registers (linear-scan) spill-counts get >>spill-counts ] with-scope ; diff --git a/basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor b/basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor new file mode 100644 index 0000000000..d12167574a --- /dev/null +++ b/basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor @@ -0,0 +1,145 @@ +USING: compiler.cfg.instructions +compiler.cfg.linear-scan.allocation.state +compiler.cfg.linear-scan.mapping cpu.architecture kernel +namespaces tools.test ; +IN: compiler.cfg.linear-scan.mapping.tests + +H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set +init-mapping + +[ + { + T{ _copy { dst 5 } { src 4 } { class int-regs } } + 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 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 20 } } + } +] [ + { + T{ register->register { from 0 } { to 1 } { reg-class int-regs } } + T{ register->register { from 1 } { to 0 } { reg-class int-regs } } + T{ register->register { from 0 } { to 1 } { reg-class float-regs } } + T{ register->register { from 1 } { to 0 } { reg-class float-regs } } + T{ register->register { from 4 } { to 5 } { reg-class int-regs } } + } mapping-instructions +] unit-test + +[ + { + 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 10 } } + } +] [ + { + T{ register->register { from 0 } { to 1 } { reg-class int-regs } } + T{ register->register { from 1 } { to 2 } { reg-class int-regs } } + T{ register->register { from 2 } { to 0 } { reg-class int-regs } } + } mapping-instructions +] unit-test + +[ + { + 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 10 } } + } +] [ + { + T{ register->register { from 1 } { to 2 } { reg-class int-regs } } + T{ register->register { from 2 } { to 0 } { reg-class int-regs } } + T{ register->register { from 0 } { to 1 } { reg-class int-regs } } + } mapping-instructions +] unit-test + +[ + { + T{ _copy { dst 1 } { src 0 } { class int-regs } } + T{ _copy { dst 2 } { src 0 } { class int-regs } } + } +] [ + { + T{ register->register { from 0 } { to 1 } { reg-class int-regs } } + T{ register->register { from 0 } { to 2 } { reg-class int-regs } } + } mapping-instructions +] unit-test + +[ + { } +] [ + { + T{ register->register { from 4 } { to 4 } { reg-class int-regs } } + } mapping-instructions +] unit-test + +[ + { + T{ _spill { src 3 } { class int-regs } { n 4 } } + T{ _reload { dst 2 } { class int-regs } { n 1 } } + } +] [ + { + T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } } + T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } } + } mapping-instructions +] unit-test + + +[ + { + T{ _copy { dst 1 } { src 0 } { class int-regs } } + T{ _copy { dst 2 } { src 0 } { class int-regs } } + T{ _copy { dst 0 } { src 3 } { class int-regs } } + } +] [ + { + T{ register->register { from 0 } { to 1 } { reg-class int-regs } } + T{ register->register { from 3 } { to 0 } { reg-class int-regs } } + T{ register->register { from 0 } { to 2 } { reg-class int-regs } } + } mapping-instructions +] unit-test + +[ + { + 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 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 10 } } + } +] [ + { + T{ register->register { from 0 } { to 1 } { reg-class int-regs } } + T{ register->register { from 0 } { to 2 } { reg-class int-regs } } + T{ register->register { from 3 } { to 0 } { reg-class int-regs } } + T{ register->register { from 4 } { to 3 } { reg-class int-regs } } + T{ register->register { from 0 } { to 4 } { reg-class int-regs } } + } mapping-instructions +] unit-test + +[ + { + 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 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 10 } } + } +] [ + { + T{ register->register { from 0 } { to 1 } { reg-class int-regs } } + T{ register->register { from 0 } { to 2 } { reg-class int-regs } } + T{ register->register { from 1 } { to 9 } { reg-class int-regs } } + T{ register->register { from 3 } { to 0 } { reg-class int-regs } } + T{ register->register { from 4 } { to 3 } { reg-class int-regs } } + T{ register->register { from 0 } { to 4 } { reg-class int-regs } } + } mapping-instructions +] unit-test diff --git a/basis/compiler/cfg/linear-scan/mapping/mapping.factor b/basis/compiler/cfg/linear-scan/mapping/mapping.factor new file mode 100644 index 0000000000..5b47f33c64 --- /dev/null +++ b/basis/compiler/cfg/linear-scan/mapping/mapping.factor @@ -0,0 +1,148 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs classes.parser classes.tuple +combinators compiler.cfg.instructions +compiler.cfg.linear-scan.allocation.state fry hashtables kernel +locals make namespaces parser sequences sets words ; +IN: compiler.cfg.linear-scan.mapping + +SYMBOL: spill-temps + +: spill-temp ( reg-class -- n ) + spill-temps get [ next-spill-slot ] cache ; + +<< + +TUPLE: operation from to reg-class ; + +SYNTAX: OPERATION: + CREATE-CLASS dup save-location + [ operation { } define-tuple-class ] + [ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ; + +>> + +OPERATION: register->memory +OPERATION: memory->register +OPERATION: register->register + +! This should never come up because of how spill slots are assigned, +! so make it an error. +: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ; + +GENERIC: >insn ( operation -- ) + +M: register->memory >insn + [ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ; + +M: memory->register >insn + [ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ; + +M: register->register >insn + [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ; + +SYMBOL: froms +SYMBOL: tos + +SINGLETONS: memory register ; + +: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ; + +: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ; + +: from-reg ( operation -- seq ) + [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ; + +: to-reg ( operation -- seq ) + [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ; + +: start? ( operations -- pair ) + from-reg tos get key? not ; + +: independent-assignment? ( operations -- pair ) + to-reg froms get key? not ; + +: set-tos/froms ( operations -- ) + [ [ [ from-reg ] keep ] H{ } map>assoc froms set ] + [ [ [ to-reg ] keep ] H{ } map>assoc tos set ] + bi ; + +:: (trace-chain) ( obj hashtable -- ) + obj to-reg froms get at* [ + dup , + obj over hashtable clone [ maybe-set-at ] keep swap + [ (trace-chain) ] [ 2drop ] if + ] [ + drop + ] if ; + +: trace-chain ( obj -- seq ) + [ + dup , + dup dup associate (trace-chain) + ] { } make prune reverse ; + +: trace-chains ( seq -- seq' ) + [ trace-chain ] map concat ; + +ERROR: resolve-error ; + +: split-cycle ( operations -- chain spilled-operation ) + unclip [ + [ set-tos/froms ] + [ + [ start? ] find nip + [ resolve-error ] unless* trace-chain + ] bi + ] dip ; + +: break-cycle-n ( operations -- operations' ) + split-cycle [ + [ from>> ] + [ reg-class>> spill-temp ] + [ reg-class>> ] + tri \ register->memory boa + ] [ + [ reg-class>> spill-temp ] + [ to>> ] + [ reg-class>> ] + tri \ memory->register boa + ] bi [ 1array ] bi@ surround ; + +: break-cycle ( operations -- operations' ) + dup length { + { 1 [ ] } + [ drop break-cycle-n ] + } case ; + +: (group-cycles) ( seq -- ) + [ + dup set-tos/froms + unclip trace-chain + [ diff ] keep , (group-cycles) + ] unless-empty ; + +: group-cycles ( seq -- seqs ) + [ (group-cycles) ] { } make ; + +: remove-dead-mappings ( seq -- seq' ) + prune [ [ from-reg ] [ to-reg ] bi = not ] filter ; + +: parallel-mappings ( operations -- seq ) + [ + [ independent-assignment? not ] partition % + [ start? not ] partition + [ trace-chain ] map concat dup % + diff group-cycles [ break-cycle ] map concat % + ] { } make remove-dead-mappings ; + +: mapping-instructions ( mappings -- insns ) + [ { } ] [ + [ + [ set-tos/froms ] [ parallel-mappings ] bi + [ [ >insn ] each ] { } make + ] with-scope + ] if-empty ; + +: init-mapping ( -- ) + H{ } clone spill-temps set ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index 7e308cf231..b5e95258bf 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -1,154 +1,7 @@ -USING: accessors arrays classes compiler.cfg -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 ; +USING: arrays compiler.cfg.linear-scan.resolve kernel +tools.test ; IN: compiler.cfg.linear-scan.resolve.tests [ { 1 2 3 4 5 6 } ] [ { 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 10 } } - T{ _copy { dst 1 } { src 0 } { class int-regs } } - 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 20 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 1 } { to 0 } { reg-class int-regs } } - T{ register->register { from 0 } { to 1 } { reg-class float-regs } } - T{ register->register { from 1 } { to 0 } { reg-class float-regs } } - T{ register->register { from 4 } { to 5 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - 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 10 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 1 } { to 2 } { reg-class int-regs } } - T{ register->register { from 2 } { to 0 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - 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 10 } } - } -] [ - { - T{ register->register { from 1 } { to 2 } { reg-class int-regs } } - T{ register->register { from 2 } { to 0 } { reg-class int-regs } } - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _copy { dst 2 } { src 0 } { class int-regs } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { } -] [ - { - T{ register->register { from 4 } { to 4 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _spill { src 3 } { class int-regs } { n 4 } } - T{ _reload { dst 2 } { class int-regs } { n 1 } } - } -] [ - { - T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } } - T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } } - } mapping-instructions -] unit-test - - -[ - { - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _copy { dst 2 } { src 0 } { class int-regs } } - T{ _copy { dst 0 } { src 3 } { class int-regs } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 3 } { to 0 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - 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 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 10 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - T{ register->register { from 3 } { to 0 } { reg-class int-regs } } - T{ register->register { from 4 } { to 3 } { reg-class int-regs } } - T{ register->register { from 0 } { to 4 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - 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 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 10 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - T{ register->register { from 1 } { to 9 } { reg-class int-regs } } - T{ register->register { from 3 } { to 0 } { reg-class int-regs } } - T{ register->register { from 4 } { to 3 } { reg-class int-regs } } - T{ register->register { from 0 } { to 4 } { reg-class int-regs } } - } mapping-instructions -] unit-test diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 196d8e439f..7b7f242e4e 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -1,36 +1,13 @@ -! Copyright (C) 2009 Slava Pestov, Doug Coleman. +! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -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.allocation.state -compiler.cfg.linear-scan.assignment compiler.cfg.liveness ; +USING: accessors arrays assocs combinators +combinators.short-circuit fry kernel locals +make math sequences +compiler.cfg.instructions +compiler.cfg.linear-scan.assignment +compiler.cfg.linear-scan.mapping 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 ; - -SYNTAX: OPERATION: - CREATE-CLASS dup save-location - [ operation { } define-tuple-class ] - [ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ; - ->> - -OPERATION: register->memory -OPERATION: memory->register -OPERATION: register->register - -! This should never come up because of how spill slots are assigned, -! so make it an error. -: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ; - : add-mapping ( from to reg-class -- ) over spill-slot? [ pick spill-slot? @@ -53,118 +30,6 @@ OPERATION: register->register [ resolve-value-data-flow ] with with each ] { } make ; -GENERIC: >insn ( operation -- ) - -M: register->memory >insn - [ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ; - -M: memory->register >insn - [ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ; - -M: register->register >insn - [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ; - -SYMBOL: froms -SYMBOL: tos - -SINGLETONS: memory register ; - -: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ; - -: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ; - -: from-reg ( operation -- seq ) - [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ; - -: to-reg ( operation -- seq ) - [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ; - -: start? ( operations -- pair ) - from-reg tos get key? not ; - -: independent-assignment? ( operations -- pair ) - to-reg froms get key? not ; - -: set-tos/froms ( operations -- ) - [ [ [ from-reg ] keep ] H{ } map>assoc froms set ] - [ [ [ to-reg ] keep ] H{ } map>assoc tos set ] - bi ; - -:: (trace-chain) ( obj hashtable -- ) - obj to-reg froms get at* [ - dup , - obj over hashtable clone [ maybe-set-at ] keep swap - [ (trace-chain) ] [ 2drop ] if - ] [ - drop - ] if ; - -: trace-chain ( obj -- seq ) - [ - dup , - dup dup associate (trace-chain) - ] { } make prune reverse ; - -: trace-chains ( seq -- seq' ) - [ trace-chain ] map concat ; - -ERROR: resolve-error ; - -: split-cycle ( operations -- chain spilled-operation ) - unclip [ - [ set-tos/froms ] - [ - [ start? ] find nip - [ resolve-error ] unless* trace-chain - ] bi - ] dip ; - -: break-cycle-n ( operations -- operations' ) - split-cycle [ - [ from>> ] - [ reg-class>> spill-temp ] - [ reg-class>> ] - tri \ register->memory boa - ] [ - [ reg-class>> spill-temp ] - [ to>> ] - [ reg-class>> ] - tri \ memory->register boa - ] bi [ 1array ] bi@ surround ; - -: break-cycle ( operations -- operations' ) - dup length { - { 1 [ ] } - [ drop break-cycle-n ] - } case ; - -: (group-cycles) ( seq -- ) - [ - dup set-tos/froms - unclip trace-chain - [ diff ] keep , (group-cycles) - ] unless-empty ; - -: group-cycles ( seq -- seqs ) - [ (group-cycles) ] { } make ; - -: remove-dead-mappings ( seq -- seq' ) - prune [ [ from-reg ] [ to-reg ] bi = not ] filter ; - -: parallel-mappings ( operations -- seq ) - [ - [ independent-assignment? not ] partition % - [ start? not ] partition - [ trace-chain ] map concat dup % - diff group-cycles [ break-cycle ] map concat % - ] { } make remove-dead-mappings ; - -: mapping-instructions ( mappings -- insns ) - [ - [ set-tos/froms ] [ parallel-mappings ] bi - [ [ >insn ] each ] { } make - ] with-scope ; - : fork? ( from to -- ? ) { [ drop successors>> length 1 >= ] @@ -206,5 +71,4 @@ 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 ; diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor old mode 100644 new mode 100755 index 97ebc7cc3e..93adc4c0f9 --- a/basis/compiler/cfg/optimizer/optimizer-tests.factor +++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor @@ -2,7 +2,7 @@ USING: accessors arrays compiler.cfg.checker compiler.cfg.debugger compiler.cfg.def-use compiler.cfg.instructions fry kernel kernel.private math math.private sbufs sequences sequences.private sets -slots.private strings tools.test vectors ; +slots.private strings tools.test vectors layouts ; IN: compiler.cfg.optimizer.tests ! Miscellaneous tests @@ -35,10 +35,11 @@ IN: compiler.cfg.optimizer.tests [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test ] each -[ t ] -[ +cell 8 = [ + [ t ] [ - HEX: 7fff fixnum-bitand 13 fixnum-shift-fast - 112 23 fixnum-shift-fast fixnum+fast - ] test-mr first instructions>> [ ##add? ] any? -] unit-test + [ + 1 50 fixnum-shift-fast fixnum+fast + ] test-mr first instructions>> [ ##add? ] any? + ] unit-test +] when diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 50762c2b66..816368466f 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs classes classes.algebra classes.tuple classes.tuple.private kernel accessors math math.intervals -namespaces sequences words combinators +namespaces sequences words combinators byte-arrays strings arrays compiler.tree.propagation.copy ; IN: compiler.tree.propagation.info @@ -66,12 +66,17 @@ DEFER: [ read-only>> [ ] [ drop f ] if ] 2map f prefix ; +UNION: fixed-length array byte-array string ; + : init-literal-info ( info -- info ) + [-inf,inf] >>interval dup literal>> class >>class - dup literal>> dup real? [ [a,a] >>interval ] [ - [ [-inf,inf] >>interval ] dip - dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if - ] if ; inline + dup literal>> { + { [ dup real? ] [ [a,a] >>interval ] } + { [ dup tuple? ] [ tuple-slot-infos >>slots ] } + { [ dup fixed-length? ] [ length >>length ] } + [ drop ] + } cond ; inline : init-value-info ( info -- info ) dup literal?>> [ diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 9cb0e41291..32c9f4ed0b 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -331,6 +331,16 @@ cell-bits 32 = [ [ { fixnum } declare dup 10 eq? [ "A" throw ] unless ] final-literals ] unit-test +[ V{ 3 } ] [ [ [ { 1 2 3 } ] [ { 4 5 6 } ] if length ] final-literals ] unit-test + +[ V{ 3 } ] [ [ [ B{ 1 2 3 } ] [ B{ 4 5 6 } ] if length ] final-literals ] unit-test + +[ V{ 3 } ] [ [ [ "yay" ] [ "hah" ] if length ] final-literals ] unit-test + +[ V{ 3 } ] [ [ 3 length ] final-literals ] unit-test + +[ V{ 3 } ] [ [ 3 f length ] final-literals ] unit-test + ! Slot propagation TUPLE: prop-test-tuple { x integer } ; 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..6635fbeaf2 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -1,37 +1,25 @@ -! 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 } ; +V A vectors.functor:define-vector -: ( 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 +M: V contract 2drop ; M: V pprint-delims drop \ V{ \ } ; diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor index 8ce45ccc15..b537f448d5 100755 --- a/basis/struct-arrays/struct-arrays-tests.factor +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -1,6 +1,6 @@ IN: struct-arrays.tests USING: struct-arrays tools.test kernel math sequences -alien.syntax alien.c-types destructors libc accessors ; +alien.syntax alien.c-types destructors libc accessors sequences.private ; C-STRUCT: test-struct { "int" "x" } @@ -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 "test-struct" 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..60b9af0f19 100755 --- a/basis/struct-arrays/struct-arrays.factor +++ b/basis/struct-arrays/struct-arrays.factor @@ -10,6 +10,7 @@ TUPLE: struct-array { element-size array-capacity read-only } ; M: struct-array length length>> ; +M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; M: struct-array nth-unsafe [ element-size>> * ] [ underlying>> ] bi ; @@ -20,6 +21,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..f57c64152c --- /dev/null +++ b/basis/struct-vectors/struct-vectors-tests.factor @@ -0,0 +1,21 @@ +IN: struct-vectors.tests +USING: struct-vectors tools.test alien.c-types alien.syntax +namespaces 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..5a0654ea16 --- /dev/null +++ b/basis/struct-vectors/struct-vectors.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types 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 byte-length underlying>> byte-length ; +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 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 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 diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 0e6deb7746..004b543c7f 100644 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -176,3 +176,6 @@ H{ } "x" set [ 1 ] [ "h" get assoc-size ] unit-test [ 1 ] [ 2 "h" get at ] unit-test + +! Random test case +[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test \ No newline at end of file diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 927a404519..0a301b3e38 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1107,7 +1107,7 @@ HELP: replicate { "newseq" sequence } } { $description "Calls the quotation for every element of the sequence in order. However, the element is not passed to the quotation -- it is dropped, and the quotation produces an element of its own that is collected into a sequence of the same class as the input sequence." } { $examples - { $unchecked-example "USING: prettyprint kernel sequences ;" + { $unchecked-example "USING: kernel prettyprint random sequences ;" "5 [ 100 random ] replicate ." "{ 52 10 45 81 30 }" }