Merge branch 'master' of git://factorcode.org/git/factor

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 {
+    compiler-descr link-descr append prepend prepend ;
-        { [ 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
-    { "-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 ]
+    args name [ library-path ]
-    [ ".o" append ] bi [ temp-file ] bi@ 2array
+    [ ".o" append temp-file ] bi 2array
     lang link-command try-process ;
 
 :: compile-to-library ( lang args contents name -- )

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" <c-object>
+    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: <string>
+
+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 >>

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
+generalizations grouping io.directories io.files
-kernel lexer math math.order math.ranges multiline namespaces
+io.files.info io.files.temp kernel lexer math math.order
-sequences splitting strings system vocabs.loader
+math.ranges multiline namespaces sequences source-files
-vocabs.parser words ;
+splitting strings system vocabs.loader vocabs.parser words
+alien.c-types alien.structs make parser ;
 IN: alien.inline
 
 <PRIVATE
@@ -41,15 +42,12 @@ SYMBOL: c-strings
 : 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 ;
-
 : compile-library? ( -- ? )
-    library-path dup exists? [
+    c-library get library-path dup exists? [
-        current-vocab vocab-source-path
+        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 ;

basis/alien/inline/tests/tests.factor

@@ -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: <string>
-
-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 >>

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: <bit-vector>
-{ $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{

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
+<< "bit-vector" create-class-in \ bit-array \ <bit-array> define-vector >>
-{ underlying bit-array initial: ?{ } }
-{ length array-capacity } ;
-
-: <bit-vector> ( n -- bit-vector )
-    <bit-array> 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 [ <bit-array> ] [ >fixnum ] bi bit-vector boa ;
-
-M: bit-vector equal?
-    over bit-vector? [ sequence= ] [ 2drop f ] if ;
-
-M: bit-array new-resizable drop <bit-vector> ;
-
-INSTANCE: bit-vector growable
 
 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 ;

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 ;
 

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 -- ? )
+: spill-live-out? ( live-interval n -- ? ) [ uses>> last ] dip < ;
-    { [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ;
 
-: 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 -- )
+: spill ( live-interval n -- )
-    start>> {
+    {
-        { [ 2dup [ uses>> last ] dip < ] [ drop split-live-out ] }
+        { [ 2dup spill-live-out? ] [ drop spill-live-out ] }
-        { [ 2dup [ uses>> first ] dip > ] [ drop split-live-in ] }
+        { [ 2dup spill-live-in? ] [ drop spill-live-in ] }
         [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ]
     } cond ;
 
-: (split-intersecting-active) ( active new -- )
+:: spill-intersecting-active ( new reg -- )
-    [ drop delete-active ]
+    ! If there is an active interval using 'reg' (there should be at
-    [ (split-intersecting) ] 2bi ;
+    ! 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 -- )
+:: spill-intersecting-inactive ( new reg -- )
-    [ [ vreg>> active-intervals-for ] keep ] dip
+    ! Any inactive intervals using 'reg' are split and spilled
-    [ '[ _ _ split-intersecting? ] filter ] 2keep drop
+    ! and removed from the inactive set.
-    '[ _ (split-intersecting-active) ] each ;
+    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 -- )
+: spill-intersecting ( new reg -- )
-    [ drop delete-inactive ]
+    ! Split and spill all active and inactive intervals
-    [ (split-intersecting) ] 2bi ;
+    ! which intersect 'new' and use 'reg'.
-
+    [ spill-intersecting-active ]
-: split-intersecting-inactive ( new reg -- )
+    [ spill-intersecting-inactive ]
-    [ [ 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 ;
+    ! 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 ;
 

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 ;

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>> <spill-slot> ] [ 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 ;
+        ] filter-here
+    ] { } make mapping-instructions % ;
 
 : insert-reload ( live-interval -- )
     {

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=

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 ;

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

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 <spill-slot> ]
+        [ reg-class>> ]
+        tri \ register->memory boa
+    ] [
+        [ reg-class>> spill-temp <spill-slot> ]
+        [ 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 ;

basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor

@@ -1,154 +1,7 @@
-USING: accessors arrays classes compiler.cfg
+USING: arrays compiler.cfg.linear-scan.resolve kernel
-compiler.cfg.debugger compiler.cfg.instructions
+tools.test ;
-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 ;
 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

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
+USING: accessors arrays assocs combinators
-combinators combinators.short-circuit fry hashtables kernel locals
+combinators.short-circuit fry kernel locals
-make math math.order namespaces sequences sets words parser
+make math sequences
-compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state
+compiler.cfg.instructions
-compiler.cfg.linear-scan.assignment compiler.cfg.liveness ;
+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 <spill-slot> ]
-        [ reg-class>> ]
-        tri \ register->memory boa
-    ] [
-        [ reg-class>> spill-temp <spill-slot> ]
-        [ 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 ;

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
+            1 50 fixnum-shift-fast fixnum+fast
         ] test-mr first instructions>> [ ##add? ] any?
-] unit-test
+    ] unit-test
+] when

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: <literal-info>
     [ read-only>> [ <literal-info> ] [ 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 ] [
+    dup literal>> {
-        [ [-inf,inf] >>interval ] dip
+        { [ dup real? ] [ [a,a] >>interval ] }
-        dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
+        { [ dup tuple? ] [ tuple-slot-infos >>slots ] }
-    ] if ; inline
+        { [ dup fixed-length? ] [ length <literal-info> >>length ] }
+        [ drop ]
+    } cond ; inline
 
 : init-value-info ( info -- info )
     dup literal?>> [

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 <byte-array> length ] final-literals ] unit-test
+
+[ V{ 3 } ] [ [ 3 f <string> length ] final-literals ] unit-test
+
 ! Slot propagation
 TUPLE: prop-test-tuple { x integer } ;
 

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) ;

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
 <A> IS      <${A}>
 
-V   DEFINES-CLASS ${T}-vector
+>V  DEFERS >${V}
-<V> DEFINES <${V}>
->V  DEFINES >${V}
 V{  DEFINES ${V}{
 
 WHERE
 
-TUPLE: V { underlying A } { length array-capacity } ;
+V A <A> vectors.functor:define-vector
 
-: <V> ( capacity -- vector ) <A> 0 V boa ; inline
+M: V contract 2drop ;
-
-M: V like
-    drop dup V instance? [
-        dup A instance? [ dup length V boa ] [ >V ] if
-    ] unless ;
-
-M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
-
-M: A new-resizable drop <V> ;
-
-M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
-
-: >V ( seq -- vector ) V new clone-like ; inline
 
 M: V pprint-delims drop \ V{ \ } ;
 

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" }
@@ -36,3 +36,5 @@ C-STRUCT: test-struct
         &free drop
     ] with-destructors
 ] unit-test
+
+[ 15 ] [ 15 10 "test-struct" <struct-array> resize length ] unit-test

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 <displaced-alien> ;
@@ -20,6 +21,10 @@ M: struct-array set-nth-unsafe
 M: struct-array new-sequence
     element-size>> [ * <byte-array> ] 2keep struct-array boa ; inline
 
+M: struct-array resize ( n seq -- newseq )
+    [ [ element-size>> * ] [ underlying>> ] bi resize ] [ element-size>> ] 2bi
+    struct-array boa ;
+
 : <struct-array> ( length c-type -- struct-array )
     heap-size [ * <byte-array> ] 2keep struct-array boa ; inline
 

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: <struct-vector>
+{ $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 <struct-vector> } ;
+
+ABOUT: "struct-vectors"

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" <c-object>
+    [ set-point-y ] keep
+    [ set-point-x ] keep ;
+
+[ ] [ 1 "point" <struct-vector> "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

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 } ;
+
+: <struct-vector> ( capacity c-type -- struct-vector )
+    [ <struct-array> 0 ] keep struct-vector boa ; inline
+
+M: struct-vector byte-length underlying>> byte-length ;
+M: struct-vector new-sequence
+    [ c-type>> <struct-array> ] [ [ >fixnum ] [ c-type>> ] bi* ] 2bi
+    struct-vector boa ;
+
+M: struct-vector contract 2drop ;
+
+M: struct-array new-resizable c-type>> <struct-vector> ;
+
+INSTANCE: struct-vector growable

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 <A> -- )
+
+<V> DEFINES <${V}>
+>V  DEFINES >${V}
+
+WHERE
+
+TUPLE: V { underlying A } { length array-capacity } ;
+
+: <V> ( capacity -- vector ) <A> 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 [ <A> ] [ >fixnum ] bi V boa ;
+
+M: A new-resizable drop <V> ;
+
+M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
+
+: >V ( seq -- vector ) V new clone-like ; inline
+
+INSTANCE: V growable
+
+;FUNCTOR

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,

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

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

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 }"
     }