Merge branch 'master' of git://factorcode.org/git/factor into llvm
Matthew Willis
commit
16a2d8aa79
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! 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
|
||||
prettyprint.backend prettyprint.custom prettyprint.sections
|
||||
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.linear-scan compiler.cfg.two-operand
|
||||
compiler.cfg.liveness compiler.cfg.optimizer
|
||||
compiler.cfg.mr ;
|
||||
compiler.cfg.mr compiler.cfg ;
|
||||
IN: compiler.cfg.debugger
|
||||
|
||||
GENERIC: test-cfg ( quot -- cfgs )
|
||||
|
|
@ -49,3 +49,12 @@ M: vreg pprint*
|
|||
M: ds-loc pprint* \ D 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) ;
|
||||
|
|
@ -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 +0,0 @@
|
|||
Stack height normalization coalesces height changes at start of basic block
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -34,6 +34,3 @@ IN: compiler.cfg.linear-scan.debugger
|
|||
|
||||
: live-intervals. ( seq -- )
|
||||
[ interval-picture ] map simple-table. ;
|
||||
|
||||
: test-bb ( insns n -- )
|
||||
[ <basic-block> swap >>number swap >>instructions ] keep set ;
|
||||
|
|
@ -1563,12 +1563,6 @@ V{
|
|||
T{ ##return }
|
||||
} 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
|
||||
|
||||
{ 1 2 3 4 } test-linear-scan-on-cfg
|
||||
|
|
|
|||
|
|
@ -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.live-intervals
|
||||
compiler.cfg.linear-scan.numbering
|
||||
|
|
@ -62,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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,6 @@
|
|||
USING: kernel sequences accessors combinators namespaces
|
||||
compiler.cfg.predecessors
|
||||
compiler.cfg.useless-blocks
|
||||
compiler.cfg.height
|
||||
compiler.cfg.stack-analysis
|
||||
compiler.cfg.alias-analysis
|
||||
compiler.cfg.value-numbering
|
||||
|
|
@ -25,9 +24,8 @@ SYMBOL: check-optimizer?
|
|||
: optimize-cfg ( cfg -- cfg' )
|
||||
[
|
||||
compute-predecessors
|
||||
delete-useless-blocks
|
||||
! delete-useless-blocks
|
||||
delete-useless-conditionals
|
||||
normalize-height
|
||||
stack-analysis
|
||||
compute-liveness
|
||||
alias-analysis
|
||||
|
|
|
|||
|
|
@ -8,7 +8,12 @@ TUPLE: vreg { reg-class read-only } { n read-only } ;
|
|||
SYMBOL: vreg-counter
|
||||
: 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: ds-loc < loc ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -1,65 +1,83 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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 ;
|
||||
IN: compiler.cfg.stack-analysis.merge
|
||||
|
||||
! XXX critical edges
|
||||
|
||||
: initial-state ( bb states -- state ) 2drop <state> ;
|
||||
|
||||
: 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 )
|
||||
dup all-equal? [ first ] [ must-equal-failed ] if ;
|
||||
: merge-ds-heights ( state predecessors states -- state )
|
||||
[ ds-height>> ] map dup all-equal?
|
||||
[ nip first >>ds-height ]
|
||||
[ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ;
|
||||
|
||||
: merge-heights ( state predecessors states -- state )
|
||||
nip
|
||||
[ [ ds-height>> ] map must-equal >>ds-height ]
|
||||
[ [ rs-height>> ] map must-equal >>rs-height ] bi ;
|
||||
: save-rs-height ( n -- )
|
||||
dup 0 = [ drop ] [ ##inc-r ] if ;
|
||||
|
||||
: insert-peek ( predecessor loc -- vreg )
|
||||
! XXX critical edges
|
||||
'[ _ ^^peek ] add-instructions ;
|
||||
: merge-rs-heights ( state predecessors states -- state )
|
||||
[ rs-height>> ] map dup all-equal?
|
||||
[ 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
|
||||
! is the vreg storing loc from each predecessor block
|
||||
[ '[ [ _ ] dip at ] map ] keep
|
||||
'[ [ ] [ _ insert-peek ] ?if ] 2map
|
||||
'[ dup [ 2nip ] [ drop _ insert-peek ] if ] 3map
|
||||
dup all-equal? [ first ] [ ^^phi ] if ;
|
||||
|
||||
: (merge-locs) ( predecessors assocs -- assoc )
|
||||
dup [ keys ] map concat prune
|
||||
[ [ 2nip ] [ merge-loc ] 3bi ] with with
|
||||
H{ } map>assoc ;
|
||||
:: merge-locs ( state predecessors states -- state )
|
||||
states [ locs>vregs>> ] map states collect-locs
|
||||
[| key value |
|
||||
key
|
||||
predecessors states value key merge-loc
|
||||
] assoc-map
|
||||
state translate-locs
|
||||
state (>>locs>vregs)
|
||||
state ;
|
||||
|
||||
: merge-locs ( state predecessors states -- state )
|
||||
[ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
|
||||
|
||||
: merge-actual-loc ( locs>vregs loc -- vreg )
|
||||
'[ [ _ ] dip at ] map
|
||||
: merge-actual-loc ( vregs -- vreg/f )
|
||||
dup all-equal? [ first ] [ drop f ] if ;
|
||||
|
||||
: merge-actual-locs ( state predecessors states -- state )
|
||||
nip
|
||||
[ actual-locs>vregs>> ] map
|
||||
dup [ keys ] map concat prune
|
||||
[ [ nip ] [ merge-actual-loc ] 2bi ] with
|
||||
H{ } map>assoc
|
||||
[ nip ] assoc-filter
|
||||
: merge-actual-locs ( state states -- state )
|
||||
[ [ actual-locs>vregs>> ] map ] keep collect-locs
|
||||
[ merge-actual-loc ] assoc-map [ nip ] assoc-filter
|
||||
over translate-locs
|
||||
>>actual-locs>vregs ;
|
||||
|
||||
: merge-changed-locs ( state predecessors states -- state )
|
||||
nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
|
||||
: merge-changed-locs ( state states -- state )
|
||||
[ changed-locs>> ] map assoc-combine >>changed-locs ;
|
||||
|
||||
ERROR: cannot-merge-poisoned states ;
|
||||
|
||||
: multiple-predecessors ( bb states -- state )
|
||||
dup [ not ] any? [
|
||||
[ <state> ] 2dip
|
||||
sift merge-heights
|
||||
2drop <state>
|
||||
] [
|
||||
dup [ poisoned?>> ] any? [
|
||||
cannot-merge-poisoned
|
||||
|
|
@ -67,10 +85,11 @@ ERROR: cannot-merge-poisoned states ;
|
|||
[ state new ] 2dip
|
||||
[ predecessors>> ] dip
|
||||
{
|
||||
[ merge-ds-heights ]
|
||||
[ merge-rs-heights ]
|
||||
[ merge-locs ]
|
||||
[ merge-actual-locs ]
|
||||
[ merge-heights ]
|
||||
[ merge-changed-locs ]
|
||||
[ nip merge-actual-locs ]
|
||||
[ nip merge-changed-locs ]
|
||||
} 2cleave
|
||||
] if
|
||||
] if ;
|
||||
|
|
@ -82,4 +101,4 @@ ERROR: cannot-merge-poisoned states ;
|
|||
{ 0 [ initial-state ] }
|
||||
{ 1 [ single-predecessor ] }
|
||||
[ drop multiple-predecessors ]
|
||||
} case ;
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -2,9 +2,9 @@ USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization
|
|||
compiler.cfg.predecessors compiler.cfg.stack-analysis
|
||||
compiler.cfg.instructions sequences kernel tools.test accessors
|
||||
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
|
||||
sets namespaces ;
|
||||
sets namespaces arrays cpu.architecture ;
|
||||
IN: compiler.cfg.stack-analysis.tests
|
||||
|
||||
! 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
|
||||
delete-useless-blocks
|
||||
delete-useless-conditionals
|
||||
normalize-height
|
||||
stack-analysis
|
||||
dup check-cfg
|
||||
dup check-for-redundant-ops ;
|
||||
|
|
@ -113,3 +112,36 @@ local-only? off
|
|||
[ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
|
||||
[ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
|
||||
] 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
|
||||
|
|
@ -13,32 +13,14 @@ compiler.cfg.stack-analysis.state
|
|||
compiler.cfg.stack-analysis.merge ;
|
||||
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 -- ? )
|
||||
dup untranslate-loc n>> 0 <
|
||||
dup state get untranslate-loc n>> 0 <
|
||||
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
|
||||
|
||||
: save-changed-locs ( state -- )
|
||||
[ changed-locs>> ] [ locs>vregs>> ] bi '[
|
||||
_ at swap 2dup redundant-replace?
|
||||
[ 2drop ] [ untranslate-loc ##replace ] if
|
||||
[ 2drop ] [ state get untranslate-loc ##replace ] if
|
||||
] assoc-each ;
|
||||
|
||||
ERROR: poisoned-state state ;
|
||||
|
|
@ -46,6 +28,8 @@ ERROR: poisoned-state state ;
|
|||
: sync-state ( -- )
|
||||
state get {
|
||||
[ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
|
||||
[ ds-height>> save-ds-height ]
|
||||
[ rs-height>> save-rs-height ]
|
||||
[ save-changed-locs ]
|
||||
[ clear-state ]
|
||||
} cleave ;
|
||||
|
|
@ -55,18 +39,16 @@ ERROR: poisoned-state state ;
|
|||
! Abstract interpretation
|
||||
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 ;
|
||||
|
||||
: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;
|
||||
|
||||
M: ##inc-r visit [ , ] [ n>> adjust-rs ] bi ;
|
||||
M: ##inc-r visit
|
||||
n>> state get [ + ] change-rs-height drop ;
|
||||
|
||||
! Instructions which don't have any effect on the stack
|
||||
UNION: neutral-insn
|
||||
##flushable
|
||||
##effect ;
|
||||
##effect
|
||||
##flushable ;
|
||||
|
||||
M: neutral-insn visit , ;
|
||||
|
||||
|
|
@ -97,20 +79,16 @@ M: sync-if-back-edge visit
|
|||
[ ##copy ] [ swap copies get set-at ] 2bi ;
|
||||
|
||||
M: ##peek visit
|
||||
dup
|
||||
[ dst>> ] [ loc>> translate-loc ] bi
|
||||
dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ;
|
||||
[ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg
|
||||
[ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ;
|
||||
|
||||
M: ##replace visit
|
||||
[ src>> resolve ] [ loc>> translate-loc ] bi
|
||||
[ src>> resolve ] [ loc>> state get translate-loc ] bi
|
||||
record-replace ;
|
||||
|
||||
M: ##copy visit
|
||||
[ call-next-method ] [ record-copy ] bi ;
|
||||
|
||||
M: ##call visit
|
||||
[ call-next-method ] [ height>> adjust-ds ] bi ;
|
||||
|
||||
! Instructions that poison the stack state
|
||||
UNION: poison-insn
|
||||
##jump
|
||||
|
|
@ -133,21 +111,11 @@ UNION: kill-vreg-insn
|
|||
##fixnum-add
|
||||
##fixnum-sub
|
||||
##alien-invoke
|
||||
##alien-indirect ;
|
||||
##alien-indirect
|
||||
##alien-callback ;
|
||||
|
||||
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
|
||||
SYMBOLS: state-in state-out ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,14 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! 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
|
||||
|
||||
TUPLE: state
|
||||
locs>vregs actual-locs>vregs changed-locs
|
||||
ds-height rs-height poisoned? ;
|
||||
{ ds-height integer }
|
||||
{ rs-height integer }
|
||||
poisoned? ;
|
||||
|
||||
: <state> ( -- state )
|
||||
state new
|
||||
|
|
@ -33,11 +36,14 @@ M: state clone
|
|||
dup changed-loc state get locs>vregs>> set-at ;
|
||||
|
||||
: clear-state ( state -- )
|
||||
[ locs>vregs>> clear-assoc ]
|
||||
[ actual-locs>vregs>> clear-assoc ]
|
||||
[ changed-locs>> clear-assoc ]
|
||||
tri ;
|
||||
0 >>ds-height 0 >>rs-height
|
||||
[ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri
|
||||
[ clear-assoc ] 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> ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ ERROR: invalid-slot-name name ;
|
|||
: parse-long-slot-name ( -- spec )
|
||||
[ 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
|
||||
#! to check for mistakes of this form:
|
||||
#!
|
||||
|
|
@ -43,12 +43,18 @@ ERROR: invalid-slot-name name ;
|
|||
{
|
||||
{ [ dup not ] [ unexpected-eof ] }
|
||||
{ [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
|
||||
{ [ dup ";" = ] [ drop f ] }
|
||||
{ [ 2dup = ] [ drop f ] }
|
||||
[ 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 ( -- )
|
||||
scan parse-slot-name [ parse-tuple-slots ] when ;
|
||||
";" parse-tuple-slots-delim ;
|
||||
|
||||
: parse-tuple-definition ( -- class superclass slots )
|
||||
CREATE-CLASS
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1 @@
|
|||
Syntax and combinators for manipulating algebraic data types
|
||||
|
|
@ -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"
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
||||
Loading…
Reference in New Issue