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

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

db4
Matthew Willis 2009-06-27 19:43:17 +09:00
parent 48863ca171 1cb6bc99da
commit 16a2d8aa79
26 changed files with 731 additions and 239 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. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: checksums.sha
SINGLETON: sha1 SINGLETON: sha1
@ -230,21 +230,21 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
: prepare-M-256 ( n seq -- ) : 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 -- ) : 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' ) : ch ( x y z -- x' )
[ bitxor bitand ] keep bitxor ; inline [ 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 ) GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
:: T1-256 ( n M H sha2 -- T1 ) :: 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 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 ) : T2-256 ( H -- T2 )
[ a swap nth S0-256 ] [ a swap nth-unsafe S0-256 ]
[ a swap slice3 maj w+ ] bi ; inline [ a swap slice3 maj w+ ] bi ; inline
:: T1-512 ( n M H sha2 -- T1 ) :: 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 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 ) : T2-512 ( H -- T2 )
[ a swap nth S0-512 ] [ a swap nth-unsafe S0-512 ]
[ a swap slice3 maj w+ ] bi ; inline [ a swap slice3 maj w+ ] bi ; inline
: update-H ( T1 T2 H -- ) : 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 ) : prepare-message-schedule ( seq sha2 -- w-seq )
[ word-size>> <sliced-groups> [ be> ] map ] [ word-size>> <sliced-groups> [ be> ] map ]
@ -309,7 +309,7 @@ M: sha2-short checksum-block
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ; [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
: seq>byte-array ( seq n -- string ) : seq>byte-array ( seq n -- string )
'[ _ >be ] map B{ } join ; '[ _ >be ] map B{ } concat-as ;
: sha1>checksum ( sha2 -- bytes ) : sha1>checksum ( sha2 -- bytes )
H>> 4 seq>byte-array ; H>> 4 seq>byte-array ;
@ -342,16 +342,14 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
drop drop
[ <sha-256-state> ] dip add-checksum-stream get-checksum ; [ <sha-256-state> ] dip add-checksum-stream get-checksum ;
: sha1-W ( t seq -- ) : 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 ) : prepare-sha1-message-schedule ( seq -- w-seq )
4 <sliced-groups> [ be> ] map 4 <sliced-groups> [ be> ] map
@ -368,11 +366,11 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
} case ; } case ;
:: inner-loop ( n H W K -- temp ) :: 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 A 5 bitroll-32
@ -380,19 +378,19 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
E E
n K nth n K nth-unsafe
n W nth n W nth-unsafe
] sum-outputs 32 bits ; ] sum-outputs 32 bits ;
:: process-sha1-chunk ( bytes H W K state -- ) :: process-sha1-chunk ( bytes H W K state -- )
80 [ 80 [
H W K inner-loop 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 ] each
state [ H [ w+ ] 2map ] change-H drop ; inline state [ H [ w+ ] 2map ] change-H drop ; inline

15
basis/compiler/cfg/debugger/debugger.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io USING: kernel words sequences quotations namespaces io vectors
classes.tuple accessors prettyprint prettyprint.config classes.tuple accessors prettyprint prettyprint.config
prettyprint.backend prettyprint.custom prettyprint.sections prettyprint.backend prettyprint.custom prettyprint.sections
parser compiler.tree.builder compiler.tree.optimizer parser compiler.tree.builder compiler.tree.optimizer
@ -8,7 +8,7 @@ compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.registers compiler.cfg.stack-frame compiler.cfg.registers compiler.cfg.stack-frame
compiler.cfg.linear-scan compiler.cfg.two-operand compiler.cfg.linear-scan compiler.cfg.two-operand
compiler.cfg.liveness compiler.cfg.optimizer compiler.cfg.liveness compiler.cfg.optimizer
compiler.cfg.mr ; compiler.cfg.mr compiler.cfg ;
IN: compiler.cfg.debugger IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs ) GENERIC: test-cfg ( quot -- cfgs )
@ -49,3 +49,12 @@ M: vreg pprint*
M: ds-loc pprint* \ D pprint-loc ; M: ds-loc pprint* \ D pprint-loc ;
M: rs-loc pprint* \ R pprint-loc ; M: rs-loc pprint* \ R pprint-loc ;
: test-bb ( insns n -- )
[ <basic-block> swap >>number swap >>instructions ] keep set ;
: test-diamond ( -- )
1 get 1vector 0 get (>>successors)
2 get 3 get V{ } 2sequence 1 get (>>successors)
4 get 1vector 2 get (>>successors)
4 get 1vector 3 get (>>successors) ;

55
basis/compiler/cfg/height/height.factor
View File

@ -1,55 +0,0 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math namespaces sequences kernel fry
compiler.cfg compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.liveness compiler.cfg.local ;
IN: compiler.cfg.height
! Combine multiple stack height changes into one at the
! start of the basic block.
SYMBOL: ds-height
SYMBOL: rs-height
GENERIC: compute-heights ( insn -- )
M: ##inc-d compute-heights n>> ds-height [ + ] change ;
M: ##inc-r compute-heights n>> rs-height [ + ] change ;
M: insn compute-heights drop ;
GENERIC: normalize-height* ( insn -- insn' )
: normalize-inc-d/r ( insn stack -- insn' )
swap n>> '[ _ - ] change f ; inline
M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
GENERIC: loc-stack ( loc -- stack )
M: ds-loc loc-stack drop ds-height ;
M: rs-loc loc-stack drop rs-height ;
GENERIC: <loc> ( n stack -- loc )
M: ds-loc <loc> drop <ds-loc> ;
M: rs-loc <loc> drop <rs-loc> ;
: normalize-peek/replace ( insn -- insn' )
[ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
M: ##peek normalize-height* normalize-peek/replace ;
M: ##replace normalize-height* normalize-peek/replace ;
M: insn normalize-height* ;
: height-step ( insns -- insns' )
0 ds-height set
0 rs-height set
[ [ compute-heights ] each ]
[ [ [ normalize-height* ] map sift ] with-scope ] bi
ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
: normalize-height ( cfg -- cfg' )
[ drop ] [ height-step ] local-optimization ;

1
basis/compiler/cfg/height/summary.txt
View File

@ -1 +0,0 @@
Stack height normalization coalesces height changes at start of basic block

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

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

3
basis/compiler/cfg/linear-scan/debugger/debugger.factor
View File

@ -34,6 +34,3 @@ IN: compiler.cfg.linear-scan.debugger
: live-intervals. ( seq -- ) : live-intervals. ( seq -- )
[ interval-picture ] map simple-table. ; [ interval-picture ] map simple-table. ;
: test-bb ( insns n -- )
[ <basic-block> swap >>number swap >>instructions ] keep set ;

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

@ -1563,12 +1563,6 @@ V{
T{ ##return } T{ ##return }
} 4 test-bb } 4 test-bb
: test-diamond ( -- )
1 get 1vector 0 get (>>successors)
2 get 3 get V{ } 2sequence 1 get (>>successors)
4 get 1vector 2 get (>>successors)
4 get 1vector 3 get (>>successors) ;
test-diamond test-diamond
{ 1 2 3 4 } test-linear-scan-on-cfg { 1 2 3 4 } test-linear-scan-on-cfg

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

@ -1,4 +1,5 @@
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.debugger
compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.numbering compiler.cfg.linear-scan.numbering
@ -63,3 +64,149 @@ T{ live-interval
[ f ] [ [ f ] [
1 get test-live-interval-2 reload-from 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

124
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. ! 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 IN: compiler.cfg.linear-scan.resolve
<< <<
@ -75,8 +77,118 @@ M: memory->register >insn
M: register->register >insn M: register->register >insn
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ; [ 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 ) : mapping-instructions ( mappings -- insns )
[ [ >insn ] each ] { } make ; [
[ init-temp-spill ]
[ set-tos/froms ]
[ parallel-mappings ] tri
[ [ >insn ] each ] { } make
] with-scope ;
: fork? ( from to -- ? ) : fork? ( from to -- ? )
[ successors>> length 1 >= ] [ successors>> length 1 >= ]

4
basis/compiler/cfg/optimizer/optimizer.factor
View File

@ -3,7 +3,6 @@
USING: kernel sequences accessors combinators namespaces USING: kernel sequences accessors combinators namespaces
compiler.cfg.predecessors compiler.cfg.predecessors
compiler.cfg.useless-blocks compiler.cfg.useless-blocks
compiler.cfg.height
compiler.cfg.stack-analysis compiler.cfg.stack-analysis
compiler.cfg.alias-analysis compiler.cfg.alias-analysis
compiler.cfg.value-numbering compiler.cfg.value-numbering
@ -25,9 +24,8 @@ SYMBOL: check-optimizer?
: optimize-cfg ( cfg -- cfg' ) : optimize-cfg ( cfg -- cfg' )
[ [
compute-predecessors compute-predecessors
delete-useless-blocks ! delete-useless-blocks
delete-useless-conditionals delete-useless-conditionals
normalize-height
stack-analysis stack-analysis
compute-liveness compute-liveness
alias-analysis alias-analysis

7
basis/compiler/cfg/registers/registers.factor
View File

@ -8,7 +8,12 @@ TUPLE: vreg { reg-class read-only } { n read-only } ;
SYMBOL: vreg-counter SYMBOL: vreg-counter
: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ; : next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
! Stack locations ! Stack locations -- 'n' is an index starting from the top of the stack
! going down. So 0 is the top of the stack, 1 is what would be the top
! of the stack after a 'drop', and so on.
! ##inc-d and ##inc-r affect locations as follows. Location D 0 before
! an ##inc-d 1 becomes D 1 after ##inc-d 1.
TUPLE: loc { n read-only } ; TUPLE: loc { n read-only } ;
TUPLE: ds-loc < loc ; TUPLE: ds-loc < loc ;

93
basis/compiler/cfg/stack-analysis/merge/merge-tests.factor Normal file
View File

@ -0,0 +1,93 @@
IN: compiler.cfg.stack-analysis.merge.tests
USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
compiler.cfg.instructions compiler.cfg.stack-analysis.state
compiler.cfg compiler.cfg.registers compiler.cfg.debugger
cpu.architecture make assocs
sequences kernel classes ;
[
{ D 0 }
{ V int-regs 0 V int-regs 1 }
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
<state> H{ { D 0 V int-regs 0 } } >>locs>vregs
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
[ merge-locs locs>vregs>> keys ] { } make first inputs>>
] unit-test
[
{ D 0 }
##peek
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
[
<state>
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
[ merge-locs locs>vregs>> keys ] { } make drop
] keep first instructions>> first class
] unit-test
[
0 ##inc-d
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
[
<state> -1 >>ds-height
<state> 2array
[ merge-ds-heights ds-height>> ] { } make drop
] keep first instructions>> first class
] unit-test
[
0
{ D 0 }
{ 1 1 }
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
[
<state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
[ merge-locs [ ds-height>> ] [ locs>vregs>> keys ] bi ] { } make drop
] keep
[ instructions>> length ] map
] unit-test
[
-1
{ D -1 }
{ 1 1 }
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
[
<state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
<state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array
[ [ merge-ds-heights ] [ merge-locs ] 2bi ] { } make drop
[ ds-height>> ] [ locs>vregs>> keys ] bi
] keep
[ instructions>> length ] map
] unit-test

93
basis/compiler/cfg/stack-analysis/merge/merge.factor
View File

@ -1,65 +1,83 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs sequences accessors fry combinators grouping USING: kernel assocs sequences accessors fry combinators grouping
sets compiler.cfg compiler.cfg.hats sets locals compiler.cfg compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.stack-analysis.state ; compiler.cfg.stack-analysis.state ;
IN: compiler.cfg.stack-analysis.merge IN: compiler.cfg.stack-analysis.merge
! XXX critical edges
: initial-state ( bb states -- state ) 2drop <state> ; : initial-state ( bb states -- state ) 2drop <state> ;
: single-predecessor ( bb states -- state ) nip first clone ; : single-predecessor ( bb states -- state ) nip first clone ;
ERROR: must-equal-failed seq ; : save-ds-height ( n -- )
dup 0 = [ drop ] [ ##inc-d ] if ;
: must-equal ( seq -- elt ) : merge-ds-heights ( state predecessors states -- state )
dup all-equal? [ first ] [ must-equal-failed ] if ; [ ds-height>> ] map dup all-equal?
[ nip first >>ds-height ]
[ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ;
: merge-heights ( state predecessors states -- state ) : save-rs-height ( n -- )
nip dup 0 = [ drop ] [ ##inc-r ] if ;
[ [ ds-height>> ] map must-equal >>ds-height ]
[ [ rs-height>> ] map must-equal >>rs-height ] bi ;
: insert-peek ( predecessor loc -- vreg ) : merge-rs-heights ( state predecessors states -- state )
! XXX critical edges [ rs-height>> ] map dup all-equal?
'[ _ ^^peek ] add-instructions ; [ nip first >>rs-height ]
[ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
: merge-loc ( predecessors locs>vregs loc -- vreg ) : assoc-map-values ( assoc quot -- assoc' )
'[ _ dip ] assoc-map ; inline
: translate-locs ( assoc state -- assoc' )
'[ _ translate-loc ] assoc-map-values ;
: untranslate-locs ( assoc state -- assoc' )
'[ _ untranslate-loc ] assoc-map-values ;
: collect-locs ( loc-maps states -- assoc )
! assoc maps locs to sequences of vregs
[ untranslate-locs ] 2map
[ [ keys ] map concat prune ] keep
'[ dup _ [ at ] with map ] H{ } map>assoc ;
: insert-peek ( predecessor state loc -- vreg )
'[ _ _ swap translate-loc ^^peek ] add-instructions ;
: merge-loc ( predecessors states vregs loc -- vreg )
! Insert a ##phi in the current block where the input ! Insert a ##phi in the current block where the input
! is the vreg storing loc from each predecessor block ! is the vreg storing loc from each predecessor block
[ '[ [ _ ] dip at ] map ] keep '[ dup [ 2nip ] [ drop _ insert-peek ] if ] 3map
'[ [ ] [ _ insert-peek ] ?if ] 2map
dup all-equal? [ first ] [ ^^phi ] if ; dup all-equal? [ first ] [ ^^phi ] if ;
: (merge-locs) ( predecessors assocs -- assoc ) :: merge-locs ( state predecessors states -- state )
dup [ keys ] map concat prune states [ locs>vregs>> ] map states collect-locs
[ [ 2nip ] [ merge-loc ] 3bi ] with with [| key value |
H{ } map>assoc ; key
predecessors states value key merge-loc
] assoc-map
state translate-locs
state (>>locs>vregs)
state ;
: merge-locs ( state predecessors states -- state ) : merge-actual-loc ( vregs -- vreg/f )
[ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
: merge-actual-loc ( locs>vregs loc -- vreg )
'[ [ _ ] dip at ] map
dup all-equal? [ first ] [ drop f ] if ; dup all-equal? [ first ] [ drop f ] if ;
: merge-actual-locs ( state predecessors states -- state ) : merge-actual-locs ( state states -- state )
nip [ [ actual-locs>vregs>> ] map ] keep collect-locs
[ actual-locs>vregs>> ] map [ merge-actual-loc ] assoc-map [ nip ] assoc-filter
dup [ keys ] map concat prune over translate-locs
[ [ nip ] [ merge-actual-loc ] 2bi ] with
H{ } map>assoc
[ nip ] assoc-filter
>>actual-locs>vregs ; >>actual-locs>vregs ;
: merge-changed-locs ( state predecessors states -- state ) : merge-changed-locs ( state states -- state )
nip [ changed-locs>> ] map assoc-combine >>changed-locs ; [ changed-locs>> ] map assoc-combine >>changed-locs ;
ERROR: cannot-merge-poisoned states ; ERROR: cannot-merge-poisoned states ;
: multiple-predecessors ( bb states -- state ) : multiple-predecessors ( bb states -- state )
dup [ not ] any? [ dup [ not ] any? [
[ <state> ] 2dip 2drop <state>
sift merge-heights
] [ ] [
dup [ poisoned?>> ] any? [ dup [ poisoned?>> ] any? [
cannot-merge-poisoned cannot-merge-poisoned
@ -67,10 +85,11 @@ ERROR: cannot-merge-poisoned states ;
[ state new ] 2dip [ state new ] 2dip
[ predecessors>> ] dip [ predecessors>> ] dip
{ {
[ merge-ds-heights ]
[ merge-rs-heights ]
[ merge-locs ] [ merge-locs ]
[ merge-actual-locs ] [ nip merge-actual-locs ]
[ merge-heights ] [ nip merge-changed-locs ]
[ merge-changed-locs ]
} 2cleave } 2cleave
] if ] if
] if ; ] if ;

38
basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
View File

@ -2,9 +2,9 @@ USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization
compiler.cfg.predecessors compiler.cfg.stack-analysis compiler.cfg.predecessors compiler.cfg.stack-analysis
compiler.cfg.instructions sequences kernel tools.test accessors compiler.cfg.instructions sequences kernel tools.test accessors
sequences.private alien math combinators.private compiler.cfg sequences.private alien math combinators.private compiler.cfg
compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo compiler.cfg.checker compiler.cfg.rpo
compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
sets namespaces ; sets namespaces arrays cpu.architecture ;
IN: compiler.cfg.stack-analysis.tests IN: compiler.cfg.stack-analysis.tests
! Fundamental invariant: a basic block should not load or store a value more than once ! Fundamental invariant: a basic block should not load or store a value more than once
@ -25,7 +25,6 @@ IN: compiler.cfg.stack-analysis.tests
compute-predecessors compute-predecessors
delete-useless-blocks delete-useless-blocks
delete-useless-conditionals delete-useless-conditionals
normalize-height
stack-analysis stack-analysis
dup check-cfg dup check-cfg
dup check-for-redundant-ops ; dup check-for-redundant-ops ;
@ -113,3 +112,36 @@ local-only? off
[ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
[ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
] unit-test ] unit-test
! Correct height tracking
[ t ] [
[ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
reverse-post-order 2 swap nth
instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
2array { D 1 D 0 } set=
] unit-test
[ D 1 ] [
V{ T{ ##branch } } 0 test-bb
V{ T{ ##peek f V int-regs 0 D 2 } T{ ##branch } } 1 test-bb
V{
T{ ##peek f V int-regs 1 D 2 }
T{ ##inc-d f -1 }
T{ ##branch }
} 2 test-bb
V{ T{ ##call f \ + -1 } T{ ##branch } } 3 test-bb
V{ T{ ##return } } 4 test-bb
test-diamond
cfg new 0 get >>entry
compute-predecessors
stack-analysis
drop
3 get instructions>> second loc>>
] unit-test

62
basis/compiler/cfg/stack-analysis/stack-analysis.factor
View File

@ -13,32 +13,14 @@ compiler.cfg.stack-analysis.state
compiler.cfg.stack-analysis.merge ; compiler.cfg.stack-analysis.merge ;
IN: compiler.cfg.stack-analysis IN: compiler.cfg.stack-analysis
! Convert stack operations to register operations
GENERIC: height-for ( loc -- n )
M: ds-loc height-for drop state get ds-height>> ;
M: rs-loc height-for drop state get rs-height>> ;
: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline
GENERIC: translate-loc ( loc -- loc' )
M: ds-loc translate-loc (translate-loc) - <ds-loc> ;
M: rs-loc translate-loc (translate-loc) - <rs-loc> ;
GENERIC: untranslate-loc ( loc -- loc' )
M: ds-loc untranslate-loc (translate-loc) + <ds-loc> ;
M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
: redundant-replace? ( vreg loc -- ? ) : redundant-replace? ( vreg loc -- ? )
dup untranslate-loc n>> 0 < dup state get untranslate-loc n>> 0 <
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ; [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
: save-changed-locs ( state -- ) : save-changed-locs ( state -- )
[ changed-locs>> ] [ locs>vregs>> ] bi '[ [ changed-locs>> ] [ locs>vregs>> ] bi '[
_ at swap 2dup redundant-replace? _ at swap 2dup redundant-replace?
[ 2drop ] [ untranslate-loc ##replace ] if [ 2drop ] [ state get untranslate-loc ##replace ] if
] assoc-each ; ] assoc-each ;
ERROR: poisoned-state state ; ERROR: poisoned-state state ;
@ -46,6 +28,8 @@ ERROR: poisoned-state state ;
: sync-state ( -- ) : sync-state ( -- )
state get { state get {
[ dup poisoned?>> [ poisoned-state ] [ drop ] if ] [ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
[ ds-height>> save-ds-height ]
[ rs-height>> save-rs-height ]
[ save-changed-locs ] [ save-changed-locs ]
[ clear-state ] [ clear-state ]
} cleave ; } cleave ;
@ -55,18 +39,16 @@ ERROR: poisoned-state state ;
! Abstract interpretation ! Abstract interpretation
GENERIC: visit ( insn -- ) GENERIC: visit ( insn -- )
: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ; M: ##inc-d visit
n>> state get [ + ] change-ds-height drop ;
M: ##inc-d visit [ , ] [ n>> adjust-ds ] bi ; M: ##inc-r visit
n>> state get [ + ] change-rs-height drop ;
: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;
M: ##inc-r visit [ , ] [ n>> adjust-rs ] bi ;
! Instructions which don't have any effect on the stack ! Instructions which don't have any effect on the stack
UNION: neutral-insn UNION: neutral-insn
##flushable ##effect
##effect ; ##flushable ;
M: neutral-insn visit , ; M: neutral-insn visit , ;
@ -97,20 +79,16 @@ M: sync-if-back-edge visit
[ ##copy ] [ swap copies get set-at ] 2bi ; [ ##copy ] [ swap copies get set-at ] 2bi ;
M: ##peek visit M: ##peek visit
dup [ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg
[ dst>> ] [ loc>> translate-loc ] bi [ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ;
dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ;
M: ##replace visit M: ##replace visit
[ src>> resolve ] [ loc>> translate-loc ] bi [ src>> resolve ] [ loc>> state get translate-loc ] bi
record-replace ; record-replace ;
M: ##copy visit M: ##copy visit
[ call-next-method ] [ record-copy ] bi ; [ call-next-method ] [ record-copy ] bi ;
M: ##call visit
[ call-next-method ] [ height>> adjust-ds ] bi ;
! Instructions that poison the stack state ! Instructions that poison the stack state
UNION: poison-insn UNION: poison-insn
##jump ##jump
@ -133,21 +111,11 @@ UNION: kill-vreg-insn
##fixnum-add ##fixnum-add
##fixnum-sub ##fixnum-sub
##alien-invoke ##alien-invoke
##alien-indirect ; ##alien-indirect
##alien-callback ;
M: kill-vreg-insn visit sync-state , ; M: kill-vreg-insn visit sync-state , ;
: visit-alien-node ( node -- )
params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-ds ;
M: ##alien-invoke visit
[ call-next-method ] [ visit-alien-node ] bi ;
M: ##alien-indirect visit
[ call-next-method ] [ visit-alien-node ] bi ;
M: ##alien-callback visit , ;
! Maps basic-blocks to states ! Maps basic-blocks to states
SYMBOLS: state-in state-out ; SYMBOLS: state-in state-out ;

22
basis/compiler/cfg/stack-analysis/state/state.factor
View File

@ -1,11 +1,14 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets math ; USING: kernel accessors namespaces assocs sets math
compiler.cfg.registers ;
IN: compiler.cfg.stack-analysis.state IN: compiler.cfg.stack-analysis.state
TUPLE: state TUPLE: state
locs>vregs actual-locs>vregs changed-locs locs>vregs actual-locs>vregs changed-locs
ds-height rs-height poisoned? ; { ds-height integer }
{ rs-height integer }
poisoned? ;
: <state> ( -- state ) : <state> ( -- state )
state new state new
@ -33,11 +36,14 @@ M: state clone
dup changed-loc state get locs>vregs>> set-at ; dup changed-loc state get locs>vregs>> set-at ;
: clear-state ( state -- ) : clear-state ( state -- )
[ locs>vregs>> clear-assoc ] 0 >>ds-height 0 >>rs-height
[ actual-locs>vregs>> clear-assoc ] [ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri
[ changed-locs>> clear-assoc ] [ clear-assoc ] tri@ ;
tri ;
: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ; GENERIC# translate-loc 1 ( loc state -- loc' )
M: ds-loc translate-loc [ n>> ] [ ds-height>> ] bi* - <ds-loc> ;
M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - <rs-loc> ;
: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ; GENERIC# untranslate-loc 1 ( loc state -- loc' )
M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + <ds-loc> ;
M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + <rs-loc> ;

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

@ -266,6 +266,14 @@ PRIVATE>
[ nip require ] [ nip require ]
} 2cleave ; } 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 <PRIVATE
: tests-file-string ( vocab -- string ) : tests-file-string ( vocab -- string )

14
core/classes/tuple/parser/parser.factor
View File

@ -33,7 +33,7 @@ ERROR: invalid-slot-name name ;
: parse-long-slot-name ( -- spec ) : parse-long-slot-name ( -- spec )
[ scan , \ } parse-until % ] { } make ; [ scan , \ } parse-until % ] { } make ;
: parse-slot-name ( string/f -- ? ) : parse-slot-name-delim ( end-delim string/f -- ? )
#! This isn't meant to enforce any kind of policy, just #! This isn't meant to enforce any kind of policy, just
#! to check for mistakes of this form: #! to check for mistakes of this form:
#! #!
@ -43,12 +43,18 @@ ERROR: invalid-slot-name name ;
{ {
{ [ dup not ] [ unexpected-eof ] } { [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] } { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
{ [ dup ";" = ] [ drop f ] } { [ 2dup = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ] [ dup "{" = [ drop parse-long-slot-name ] when , t ]
} cond ; } cond nip ;
: parse-tuple-slots-delim ( end-delim -- )
dup scan parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
: parse-slot-name ( string/f -- ? )
";" swap parse-slot-name-delim ;
: parse-tuple-slots ( -- ) : parse-tuple-slots ( -- )
scan parse-slot-name [ parse-tuple-slots ] when ; ";" parse-tuple-slots-delim ;
: parse-tuple-definition ( -- class superclass slots ) : parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS CREATE-CLASS

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

@ -37,3 +37,8 @@ IN: cursors.tests
[ { 111 222 } ] [ { 111 222 } ]
[ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ] unit-test [ { 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. ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generalizations kernel math sequences USING: accessors arrays generalizations kernel math sequences
sequences.private ; sequences.private fry ;
IN: cursors IN: cursors
GENERIC: cursor-done? ( cursor -- ? ) GENERIC: cursor-done? ( cursor -- ? )
@ -127,12 +127,13 @@ M: to-sequence cursor-write
: 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline : 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline
: find-done3? ( cursor1 cursor2 cursor3 quot -- ? ) : 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 -- ) : cursor-until3 ( cursor cursor quot -- )
[ find-done3? not ] [ 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 -- ) : cursor-each3 ( cursor cursor quot -- )
[ f ] compose cursor-until3 ; inline [ f ] compose cursor-until3 ; inline

5
extra/histogram/histogram.factor
View File

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

1
extra/variants/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

1
extra/variants/summary.txt Normal file
View File

@ -0,0 +1 @@
Syntax and combinators for manipulating algebraic data types

63
extra/variants/variants-docs.factor Normal file
View File

@ -0,0 +1,63 @@
! (c)2009 Joe Groff bsd license
USING: arrays classes classes.singleton classes.tuple help.markup
help.syntax kernel multiline slots quotations ;
IN: variants
HELP: VARIANT:
{ $syntax <"
VARIANT: class-name
singleton
singleton
tuple: { slot slot slot ... }
.
.
.
; "> }
{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots are able to recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
{ $examples { $code <"
USING: kernel variants ;
IN: scratchpad
VARIANT: list
nil
cons: { { first object } { rest list } }
;
"> } } ;
HELP: match
{ $values { "branches" array } }
{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with an empty stack. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
{ $examples { $example <"
USING: kernel math prettyprint variants ;
IN: scratchpad
VARIANT: list
nil
cons: { { first object } { rest list } }
;
: list-length ( list -- length )
{
{ nil [ 0 ] }
{ cons [ nip list-length 1 + ] }
} match ;
1 2 3 4 nil <cons> <cons> <cons> <cons> list-length .
"> "4" } } ;
HELP: unboa
{ $values { "class" class } }
{ $description "Decomposes a tuple of type " { $snippet "class" } " into its component slot values by order of arguments. The inverse of " { $link boa } "." } ;
HELP: variant-class
{ $class-description "This class comprises class names that have been defined with " { $link POSTPONE: VARIANT: } ". When a " { $snippet "variant-class" } " is used as the type of a specialized " { $link tuple } " slot, the variant's first member type is used as the default " { $link initial-value } "." } ;
{ POSTPONE: VARIANT: variant-class match } related-words
ARTICLE: "variants" "Algebraic data types"
"The " { $vocab-link "variants" } " vocabulary provides syntax and combinators for defining and manipulating algebraic data types."
{ $subsection POSTPONE: VARIANT: }
{ $subsection variant-class }
{ $subsection match } ;
ABOUT: "variants"

21
extra/variants/variants-tests.factor Normal file
View File

@ -0,0 +1,21 @@
! (c)2009 Joe Groff bsd license
USING: kernel math tools.test variants ;
IN: variants.tests
VARIANT: list
nil
cons: { { first object } { rest list } }
;
[ t ] [ nil list? ] unit-test
[ t ] [ 1 nil <cons> list? ] unit-test
[ f ] [ 1 list? ] unit-test
: list-length ( list -- length )
{
{ nil [ 0 ] }
{ cons [ nip list-length 1 + ] }
} match ;
[ 4 ]
[ 5 6 7 8 nil <cons> <cons> <cons> <cons> list-length ] unit-test

59
extra/variants/variants.factor Normal file
View File

@ -0,0 +1,59 @@
! (c)2009 Joe Groff bsd license
USING: accessors arrays classes classes.mixin classes.parser
classes.singleton classes.tuple classes.tuple.parser
classes.union combinators inverse kernel lexer macros make
parser quotations sequences slots splitting words ;
IN: variants
PREDICATE: variant-class < mixin-class "variant" word-prop ;
M: variant-class initial-value*
dup members [ no-initial-value ]
[ nip first dup word? [ initial-value* ] unless ] if-empty ;
: define-tuple-class-and-boa-word ( class superclass slots -- )
pick [ define-tuple-class ] dip
dup name>> "<" ">" surround create-in swap define-boa-word ;
: define-variant-member ( member -- class )
dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ;
: define-variant-class ( class members -- )
[ [ define-mixin-class ] [ t "variant" set-word-prop ] [ ] tri ] dip
[ define-variant-member swap add-mixin-instance ] with each ;
: parse-variant-tuple-member ( name -- member )
create-class-in tuple
"{" expect
[ "}" parse-tuple-slots-delim ] { } make
3array ;
: parse-variant-member ( name -- member )
":" ?tail [ parse-variant-tuple-member ] [ create-class-in ] if ;
: parse-variant-members ( -- members )
[ scan dup ";" = not ]
[ parse-variant-member ] produce nip ;
SYNTAX: VARIANT:
CREATE-CLASS
parse-variant-members
define-variant-class ;
MACRO: unboa ( class -- )
<wrapper> \ boa [ ] 2sequence [undo] ;
GENERIC# (match-branch) 1 ( class quot -- class quot' )
M: singleton-class (match-branch)
\ drop prefix ;
M: object (match-branch)
over \ unboa [ ] 2sequence prepend ;
: ?class ( object -- class )
dup word? [ class ] unless ;
MACRO: match ( branches -- )
[ dup callable? [ first2 (match-branch) 2array ] unless ] map
[ \ dup \ ?class ] dip \ case [ ] 4sequence ;