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

basis/checksums/sha/sha.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel splitting grouping math sequences namespaces make
+USING: accessors checksums checksums.common checksums.stream
-io.binary math.bitwise checksums checksums.common
+combinators combinators.smart fry generalizations grouping
-sbufs strings combinators.smart math.ranges fry combinators
+io.binary kernel literals locals make math math.bitwise
-accessors locals checksums.stream multiline literals
+math.ranges multiline namespaces sbufs sequences
-generalizations ;
+sequences.private splitting strings ;
 IN: checksums.sha
 
 SINGLETON: sha1
@@ -230,21 +230,21 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
 
 : prepare-M-256 ( n seq -- )
     {
-        [ [ 16 - ] dip nth ]
+        [ [ 16 - ] dip nth-unsafe ]
-        [ [ 15 - ] dip nth s0-256 ]
+        [ [ 15 - ] dip nth-unsafe s0-256 ]
-        [ [ 7 - ] dip nth ]
+        [ [ 7 - ] dip nth-unsafe ]
-        [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+        [ [ 2 - ] dip nth-unsafe s1-256 w+ w+ w+ ]
         [ ]
-    } 2cleave set-nth ; inline
+    } 2cleave set-nth-unsafe ; inline
 
 : prepare-M-512 ( n seq -- )
     {
-        [ [ 16 - ] dip nth ]
+        [ [ 16 - ] dip nth-unsafe ]
-        [ [ 15 - ] dip nth s0-512 ]
+        [ [ 15 - ] dip nth-unsafe s0-512 ]
-        [ [ 7 - ] dip nth ]
+        [ [ 7 - ] dip nth-unsafe ]
-        [ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
+        [ [ 2 - ] dip nth-unsafe s1-512 w+ w+ w+ ]
         [ ]
-    } 2cleave set-nth ; inline
+    } 2cleave set-nth-unsafe ; inline
 
 : ch ( x y z -- x' )
     [ bitxor bitand ] keep bitxor ; inline
@@ -258,36 +258,36 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
 GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
 
 :: T1-256 ( n M H sha2 -- T1 )
-    n M nth
+    n M nth-unsafe
-    n sha2 K>> nth +
+    n sha2 K>> nth-unsafe +
     e H slice3 ch w+
-    e H nth S1-256 w+
+    e H nth-unsafe S1-256 w+
-    h H nth w+ ; inline
+    h H nth-unsafe w+ ; inline
 
 : T2-256 ( H -- T2 )
-    [ a swap nth S0-256 ]
+    [ a swap nth-unsafe S0-256 ]
     [ a swap slice3 maj w+ ] bi ; inline
 
 :: T1-512 ( n M H sha2 -- T1 )
-    n M nth
+    n M nth-unsafe
-    n sha2 K>> nth +
+    n sha2 K>> nth-unsafe +
     e H slice3 ch w+
-    e H nth S1-512 w+
+    e H nth-unsafe S1-512 w+
-    h H nth w+ ; inline
+    h H nth-unsafe w+ ; inline
 
 : T2-512 ( H -- T2 )
-    [ a swap nth S0-512 ]
+    [ a swap nth-unsafe S0-512 ]
     [ a swap slice3 maj w+ ] bi ; inline
 
 : update-H ( T1 T2 H -- )
-    h g pick exchange
+    h g pick exchange-unsafe
-    g f pick exchange
+    g f pick exchange-unsafe
-    f e pick exchange
+    f e pick exchange-unsafe
-    pick d pick nth w+ e pick set-nth
+    pick d pick nth-unsafe w+ e pick set-nth-unsafe
-    d c pick exchange
+    d c pick exchange-unsafe
-    c b pick exchange
+    c b pick exchange-unsafe
-    b a pick exchange
+    b a pick exchange-unsafe
-    [ w+ a ] dip set-nth ; inline
+    [ w+ a ] dip set-nth-unsafe ; inline
 
 : prepare-message-schedule ( seq sha2 -- w-seq )
     [ word-size>> <sliced-groups> [ be> ] map ]
@@ -309,7 +309,7 @@ M: sha2-short checksum-block
     [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
 
 : seq>byte-array ( seq n -- string )
-    '[ _ >be ] map B{ } join ;
+    '[ _ >be ] map B{ } concat-as ;
 
 : sha1>checksum ( sha2 -- bytes )
     H>> 4 seq>byte-array ;
@@ -342,16 +342,14 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
     drop
     [ <sha-256-state> ] dip add-checksum-stream get-checksum ;
 
-
-
 : sha1-W ( t seq -- )
     {
-        [ [ 3 - ] dip nth ]
+        [ [ 3 - ] dip nth-unsafe ]
-        [ [ 8 - ] dip nth bitxor ]
+        [ [ 8 - ] dip nth-unsafe bitxor ]
-        [ [ 14 - ] dip nth bitxor ]
+        [ [ 14 - ] dip nth-unsafe bitxor ]
-        [ [ 16 - ] dip nth bitxor 1 bitroll-32 ]
+        [ [ 16 - ] dip nth-unsafe bitxor 1 bitroll-32 ]
         [ ]
-    } 2cleave set-nth ;
+    } 2cleave set-nth-unsafe ;
 
 : prepare-sha1-message-schedule ( seq -- w-seq )
     4 <sliced-groups> [ be> ] map
@@ -368,11 +366,11 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
     } case ;
 
 :: inner-loop ( n H W K -- temp )
-    a H nth :> A
+    a H nth-unsafe :> A
-    b H nth :> B
+    b H nth-unsafe :> B
-    c H nth :> C
+    c H nth-unsafe :> C
-    d H nth :> D
+    d H nth-unsafe :> D
-    e H nth :> E
+    e H nth-unsafe :> E
     [
         A 5 bitroll-32
 
@@ -380,19 +378,19 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
 
         E
 
-        n K nth
+        n K nth-unsafe
 
-        n W nth
+        n W nth-unsafe
     ] sum-outputs 32 bits ;
 
 :: process-sha1-chunk ( bytes H W K state -- )
     80 [
         H W K inner-loop
-        d H nth e H set-nth
+        d H nth-unsafe e H set-nth-unsafe
-        c H nth d H set-nth
+        c H nth-unsafe d H set-nth-unsafe
-        b H nth 30 bitroll-32 c H set-nth
+        b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
-        a H nth b H set-nth
+        a H nth-unsafe b H set-nth-unsafe
-        a H set-nth
+        a H set-nth-unsafe
     ] each
     state [ H [ w+ ] 2map ] change-H drop ; inline
 

basis/compiler/cfg/instructions/instructions.factor

@@ -247,3 +247,5 @@ INSN: _spill src class n ;
 INSN: _reload dst class n ;
 INSN: _copy dst src class ;
 INSN: _spill-counts counts ;
+
+SYMBOL: temp-spill

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

@@ -1,10 +1,10 @@
-USING: accessors arrays compiler.cfg compiler.cfg.instructions
+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.resolve compiler.cfg.predecessors
-compiler.cfg.registers compiler.cfg.rpo
+compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel
-compiler.cfg.debugger cpu.architecture kernel
 namespaces tools.test vectors ;
 IN: compiler.cfg.linear-scan.resolve.tests
 
@@ -63,4 +63,150 @@ T{ live-interval
 
 [ f ] [
     1 get test-live-interval-2 reload-from
-] unit-test
+] unit-test
+
+[
+    {
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    }
+] [
+    {
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+    } trace-chains
+] unit-test
+
+[
+    {
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    }
+] [
+    {
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    } trace-chains
+] unit-test
+
+[
+    {
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        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 3 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    } trace-chains
+] unit-test
+
+[
+    {
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        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 3 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    } trace-chains
+] unit-test
+
+[
+    {
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    }
+] [
+    {
+        T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    } trace-chains
+] unit-test
+
+[
+    {
+        T{ _copy { dst 5 } { src 4 } { class int-regs } }
+        T{ _spill { src 1 } { class int-regs } { n 6 } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _reload { dst 0 } { class int-regs } { n 6 } }
+        T{ _spill { src 1 } { class float-regs } { n 7 } }
+        T{ _copy { dst 1 } { src 0 } { class float-regs } }
+        T{ _reload { dst 0 } { class float-regs } { n 7 } }
+    }
+] [
+    {
+        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 1 } { class int-regs } { n 3 } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _copy { dst 0 } { src 2 } { class int-regs } }
+        T{ _reload { dst 2 } { class int-regs } { n 3 } }
+    }
+] [
+    {
+        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 1 } { class int-regs } { n 3 } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _copy { dst 0 } { src 2 } { class int-regs } }
+        T{ _reload { dst 2 } { class int-regs } { n 3 } }
+    }
+] [
+    {
+        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 4 } { class int-regs } { n 4 } } }
+] [
+    {
+       T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test

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

@@ -1,9 +1,11 @@
-! Copyright (C) 2009 Slava Pestov
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel math namespaces sequences
+USING: accessors arrays assocs classes.parser classes.tuple
-classes.tuple classes.parser parser fry words make arrays
+combinators combinators.short-circuit compiler.cfg.instructions
-locals combinators compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness
-compiler.cfg.liveness compiler.cfg.instructions ;
+fry hashtables histogram kernel locals make math math.order
+namespaces parser prettyprint random sequences sets
+sorting.functor sorting.slots words ;
 IN: compiler.cfg.linear-scan.resolve
 
 <<
@@ -75,8 +77,118 @@ M: memory->register >insn
 M: register->register >insn
     [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
 
+GENERIC: >collision-table ( operation -- )
+
+M: memory->memory >collision-table
+    [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
+
+M: register->memory >collision-table
+    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
+
+M: memory->register >collision-table
+    [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
+
+M: register->register >collision-table
+    [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
+
+SYMBOL: froms
+SYMBOL: tos
+
+SINGLETONS: memory register ;
+
+GENERIC: from-loc ( operation -- obj )
+M: memory->memory from-loc drop memory ;
+M: register->memory from-loc drop register ;
+M: memory->register from-loc drop memory ;
+M: register->register from-loc drop register ;
+
+GENERIC: to-loc ( operation -- obj )
+M: memory->memory to-loc drop memory ;
+M: register->memory to-loc drop memory ;
+M: memory->register to-loc drop register ;
+M: register->register to-loc drop register ;
+
+: from-reg ( operation -- seq )
+    [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
+
+: to-reg ( operation -- seq )
+    [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
+
+: (trace-chain) ( pair -- )
+    to-reg froms get at [
+        dup length 1 = [
+            first [ , ] [ (trace-chain) ] bi
+        ] [
+            drop
+        ] if
+    ] when* ;
+
+: trace-chain ( pair -- seq )
+    [ [ , ] [ (trace-chain) ] bi ] { } make reverse ;
+
+: start? ( operations -- pair )
+    from-reg tos get key? not ;
+
+: init-temp-spill ( operations -- )
+    [ [ to>> ] [ from>> ] bi max ] [ max ] map-reduce
+    1 + temp-spill set ;
+
+: set-tos/froms ( operations -- )
+    {
+        [ [ from-reg ] collect-values froms set ]
+        [ [ to-reg ] collect-values tos set ]
+    } cleave ;
+
+: trace-chains ( operations -- operations' )
+    [ set-tos/froms ]
+    [ [ start? ] filter [ trace-chain ] map concat ] bi ;
+
+: break-cycle-n ( operations -- operations' )
+    unclip [ trace-chains ] dip
+    [
+        [ from>> temp-spill get ]
+        [ reg-class>> ] bi \ register->memory boa
+    ] [
+        [ to>> temp-spill [ get ] [ inc ] bi swap ]
+        [ reg-class>> ] bi \ memory->register boa
+    ] bi [ 1array ] bi@ surround ;
+
+: break-cycle ( operations -- operations' )
+    dup length {
+        { 1 [ drop { } ] }
+        [ drop break-cycle-n ]
+    } case ;
+
+: follow-cycle ( obj -- seq )
+   dup dup associate [
+        [ to-reg froms get at first dup dup ] dip
+        [ maybe-set-at ] keep swap
+    ] loop nip keys ;
+
+: (group-cycles) ( seq -- )
+    [
+        unclip follow-cycle [ diff ] keep , (group-cycles)
+    ] unless-empty ;
+
+: group-cycles ( seq -- seqs )
+    [ (group-cycles) ] { } make ;
+
+: partition-mappings ( mappings -- no-cycles cycles )
+    [ start? not ] partition
+    [ trace-chain ] map concat tuck diff ;
+
+: parallel-mappings ( operations -- seq )
+    partition-mappings [
+        group-cycles [ break-cycle ] map concat append
+    ] unless-empty ;
+
 : mapping-instructions ( mappings -- insns )
-    [ [ >insn ] each ] { } make ;
+    [
+        [ init-temp-spill ]
+        [ set-tos/froms ]
+        [ parallel-mappings ] tri
+        [ [ >insn ] each ] { } make
+    ] with-scope ;
 
 : fork? ( from to -- ? )
     [ successors>> length 1 >= ]
@@ -115,4 +227,4 @@ M: register->register >insn
     dup successors>> [ resolve-edge-data-flow ] with each ;
 
 : resolve-data-flow ( rpo -- )
-    [ resolve-block-data-flow ] each ;
+    [ resolve-block-data-flow ] each ;

basis/tools/scaffold/scaffold.factor

@@ -266,6 +266,14 @@ PRIVATE>
         [ nip require ]
     } 2cleave ;
 
+: scaffold-core ( string -- ) "resource:core" swap scaffold-vocab ;
+
+: scaffold-basis ( string -- ) "resource:basis" swap scaffold-vocab ;
+
+: scaffold-extra ( string -- ) "resource:extra" swap scaffold-vocab ;
+
+: scaffold-work ( string -- ) "resource:work" swap scaffold-vocab ;
+
 <PRIVATE
 
 : tests-file-string ( vocab -- string )

extra/cursors/cursors-tests.factor

@@ -37,3 +37,8 @@ IN: cursors.tests
 
 [ { 111 222 } ]
 [ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ] unit-test
+
+: test-3map ( -- seq )
+     { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ;
+
+[ { 111 222 } ] [ test-3map ] unit-test

extra/cursors/cursors.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays generalizations kernel math sequences
-sequences.private ;
+sequences.private fry ;
 IN: cursors
 
 GENERIC: cursor-done? ( cursor -- ? )
@@ -127,12 +127,13 @@ M: to-sequence cursor-write
 : 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline
 
 : find-done3? ( cursor1 cursor2 cursor3 quot -- ? )
-    3 nover 3array [ cursor-done? ] any?
+    [ 3 ndrop t ] swap '[ [ cursor-get-unsafe ] tri@ @ ]
-    [ 4 ndrop t ] [ [ [ cursor-get-unsafe ] tri@ ] dip call ] if ; inline
+    [ 3 ndup 3 narray [ cursor-done? ] any? ] 2dip if ; inline
 
 : cursor-until3 ( cursor cursor quot -- )
     [ find-done3? not ]
-    [ drop [ cursor-advance ] tri@ ] bi-curry bi-curry bi-curry bi-curry while ; inline
+    [ drop [ cursor-advance ] tri@ ]
+    bi-curry bi-curry bi-curry bi-curry while ; inline
 
 : cursor-each3 ( cursor cursor quot -- )
     [ f ] compose cursor-until3 ; inline

extra/histogram/histogram.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences assocs ;
+USING: kernel sequences assocs fry ;
 IN: histogram
 
 <PRIVATE
@@ -24,3 +24,6 @@ PRIVATE>
 
 : histogram ( seq -- hashtable )
     [ inc-at ] sequence>hashtable ;
+
+: collect-values ( seq quot: ( obj hashtable -- ) -- hash )
+    '[ [ dup @ ] dip push-at ] sequence>hashtable ; inline