steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2009-06-27 17:33:00 -05:00
parent d5179b724e 1cb6bc99da
commit d4de1d38b9
8 changed files with 344 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
basis/checksums/sha/sha.factor
View File

@ -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
io.binary math.bitwise checksums checksums.common
sbufs strings combinators.smart math.ranges fry combinators
accessors locals checksums.stream multiline literals
generalizations ;
USING: accessors checksums checksums.common checksums.stream
combinators combinators.smart fry generalizations grouping
io.binary kernel literals locals make math math.bitwise
math.ranges multiline namespaces sbufs sequences
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 ]
[ [ 15 - ] dip nth s0-256 ]
[ [ 7 - ] dip nth ]
[ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
[ [ 16 - ] dip nth-unsafe ]
[ [ 15 - ] dip nth-unsafe s0-256 ]
[ [ 7 - ] dip nth-unsafe ]
[ [ 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 ]
[ [ 15 - ] dip nth s0-512 ]
[ [ 7 - ] dip nth ]
[ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
[ [ 16 - ] dip nth-unsafe ]
[ [ 15 - ] dip nth-unsafe s0-512 ]
[ [ 7 - ] dip nth-unsafe ]
[ [ 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 sha2 K>> nth +
n M nth-unsafe
n sha2 K>> nth-unsafe +
e H slice3 ch w+
e H nth S1-256 w+
h H nth w+ ; inline
e H nth-unsafe S1-256 w+
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 sha2 K>> nth +
n M nth-unsafe
n sha2 K>> nth-unsafe +
e H slice3 ch w+
e H nth S1-512 w+
h H nth w+ ; inline
e H nth-unsafe S1-512 w+
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
g f pick exchange
f e pick exchange
pick d pick nth w+ e pick set-nth
d c pick exchange
c b pick exchange
b a pick exchange
[ w+ a ] dip set-nth ; inline
h g pick exchange-unsafe
g f pick exchange-unsafe
f e pick exchange-unsafe
pick d pick nth-unsafe w+ e pick set-nth-unsafe
d c pick exchange-unsafe
c b pick exchange-unsafe
b a pick exchange-unsafe
[ 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 ]
[ [ 8 - ] dip nth bitxor ]
[ [ 14 - ] dip nth bitxor ]
[ [ 16 - ] dip nth bitxor 1 bitroll-32 ]
[ [ 3 - ] dip nth-unsafe ]
[ [ 8 - ] dip nth-unsafe bitxor ]
[ [ 14 - ] dip nth-unsafe bitxor ]
[ [ 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
b H nth :> B
c H nth :> C
d H nth :> D
e H nth :> E
a H nth-unsafe :> A
b H nth-unsafe :> B
c H nth-unsafe :> C
d H nth-unsafe :> D
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
c H nth d H set-nth
b H nth 30 bitroll-32 c H set-nth
a H nth b H set-nth
a H set-nth
d H nth-unsafe e H set-nth-unsafe
c H nth-unsafe d H set-nth-unsafe
b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
a H nth-unsafe b H set-nth-unsafe
a H set-nth-unsafe
] each
state [ H [ w+ ] 2map ] change-H drop ; inline

2
basis/compiler/cfg/instructions/instructions.factor
View File

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

154
basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
View File

@ -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.debugger cpu.architecture kernel
compiler.cfg.registers compiler.cfg.rpo 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

126
basis/compiler/cfg/linear-scan/resolve/resolve.factor
View File

@ -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
classes.tuple classes.parser parser fry words make arrays
locals combinators compiler.cfg.linear-scan.live-intervals
compiler.cfg.liveness compiler.cfg.instructions ;
USING: accessors arrays assocs classes.parser classes.tuple
combinators combinators.short-circuit compiler.cfg.instructions
compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness
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 ;

8
basis/tools/scaffold/scaffold.factor
View File

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

5
extra/cursors/cursors-tests.factor
View File

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

9
extra/cursors/cursors.factor
View File

@ -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?
[ 4 ndrop t ] [ [ [ cursor-get-unsafe ] tri@ ] dip call ] if ; inline
[ 3 ndrop t ] swap '[ [ cursor-get-unsafe ] tri@ @ ]
[ 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

5
extra/histogram/histogram.factor
View File

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