diff --git a/basis/checksums/sha/sha.factor b/basis/checksums/sha/sha.factor index 287c39b2a1..35262bb0b0 100644 --- a/basis/checksums/sha/sha.factor +++ b/basis/checksums/sha/sha.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel splitting grouping math sequences namespaces make -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 ; : 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 ; 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>> [ 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 [ ] 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 [ 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 diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index cb56937758..60805124cd 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -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 -- ) + [ 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) ; \ No newline at end of file diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor deleted file mode 100644 index 14a0a54715..0000000000 --- a/basis/compiler/cfg/height/height.factor +++ /dev/null @@ -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: ( n stack -- loc ) - -M: ds-loc drop ; -M: rs-loc drop ; - -: normalize-peek/replace ( insn -- insn' ) - [ [ [ n>> ] [ loc-stack get ] bi + ] keep ] 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 ; diff --git a/basis/compiler/cfg/height/summary.txt b/basis/compiler/cfg/height/summary.txt deleted file mode 100644 index ce1974ad60..0000000000 --- a/basis/compiler/cfg/height/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Stack height normalization coalesces height changes at start of basic block diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 1bf94985a6..5b3e1af930 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -247,3 +247,5 @@ INSN: _spill src class n ; INSN: _reload dst class n ; INSN: _copy dst src class ; INSN: _spill-counts counts ; + +SYMBOL: temp-spill diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor index 401241722f..be3fb2bea8 100644 --- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor +++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor @@ -34,6 +34,3 @@ IN: compiler.cfg.linear-scan.debugger : live-intervals. ( seq -- ) [ interval-picture ] map simple-table. ; - -: test-bb ( insns n -- ) - [ swap >>number swap >>instructions ] keep set ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 60dfbd83bc..49352da0f7 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -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 diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index 3e98d6c9f0..fad1c022ef 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -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 \ No newline at end of file +] 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 diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 55a2eab41b..b29a661fbf 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -1,9 +1,11 @@ -! Copyright (C) 2009 Slava Pestov +! Copyright (C) 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel math namespaces sequences -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 ; \ No newline at end of file + [ resolve-block-data-flow ] each ; diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 9d481ef1d2..e789fc9c21 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -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 diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor index 0882bed06e..71f313be5a 100644 --- a/basis/compiler/cfg/registers/registers.factor +++ b/basis/compiler/cfg/registers/registers.factor @@ -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 ; diff --git a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor new file mode 100644 index 0000000000..e519308974 --- /dev/null +++ b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor @@ -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 } +] [ + + + V{ T{ ##branch } } >>instructions + V{ T{ ##branch } } >>instructions 2array + + H{ { D 0 V int-regs 0 } } >>locs>vregs + H{ { D 0 V int-regs 1 } } >>locs>vregs 2array + + [ merge-locs locs>vregs>> keys ] { } make first inputs>> +] unit-test + +[ + { D 0 } + ##peek +] [ + + + V{ T{ ##branch } } >>instructions + V{ T{ ##branch } } >>instructions 2array + + [ + + 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 +] [ + + + V{ T{ ##branch } } >>instructions + V{ T{ ##branch } } >>instructions 2array + + [ + -1 >>ds-height + 2array + + [ merge-ds-heights ds-height>> ] { } make drop + ] keep first instructions>> first class +] unit-test + +[ + 0 + { D 0 } + { 1 1 } +] [ + + + V{ T{ ##branch } } >>instructions + V{ T{ ##branch } } >>instructions 2array + + [ + -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs + 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 } +] [ + + + V{ T{ ##branch } } >>instructions + V{ T{ ##branch } } >>instructions 2array + + [ + -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs + -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 diff --git a/basis/compiler/cfg/stack-analysis/merge/merge.factor b/basis/compiler/cfg/stack-analysis/merge/merge.factor index 9db6d595bf..25b0c30033 100644 --- a/basis/compiler/cfg/stack-analysis/merge/merge.factor +++ b/basis/compiler/cfg/stack-analysis/merge/merge.factor @@ -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 ; : 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? [ - [ ] 2dip - sift merge-heights + 2drop ] [ 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 ; \ No newline at end of file + } case ; diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor index 3501825704..e01d870bf2 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor @@ -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 [ ] [ 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 \ No newline at end of file diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index 3946e0b897..0e06a2fdf5 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -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) - ; -M: rs-loc translate-loc (translate-loc) - ; - -GENERIC: untranslate-loc ( loc -- loc' ) - -M: ds-loc untranslate-loc (translate-loc) + ; -M: rs-loc untranslate-loc (translate-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 ; diff --git a/basis/compiler/cfg/stack-analysis/state/state.factor b/basis/compiler/cfg/stack-analysis/state/state.factor index d8cec0183f..f701b84763 100644 --- a/basis/compiler/cfg/stack-analysis/state/state.factor +++ b/basis/compiler/cfg/stack-analysis/state/state.factor @@ -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 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* - ; +M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - ; -: 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* + ; +M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + ; diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 5c8b868483..5fdc5ce087 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -266,6 +266,14 @@ PRIVATE> [ nip require ] } 2cleave ; +: scaffold-core ( string -- ) "resource:core" swap scaffold-vocab ; + +: scaffold-basis ( string -- ) "resource:basis" swap scaffold-vocab ; + +: scaffold-extra ( string -- ) "resource:extra" swap scaffold-vocab ; + +: scaffold-work ( string -- ) "resource:work" swap scaffold-vocab ; + : histogram ( seq -- hashtable ) [ inc-at ] sequence>hashtable ; + +: collect-values ( seq quot: ( obj hashtable -- ) -- hash ) + '[ [ dup @ ] dip push-at ] sequence>hashtable ; inline diff --git a/extra/variants/authors.txt b/extra/variants/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/variants/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/variants/summary.txt b/extra/variants/summary.txt new file mode 100644 index 0000000000..142366be00 --- /dev/null +++ b/extra/variants/summary.txt @@ -0,0 +1 @@ +Syntax and combinators for manipulating algebraic data types diff --git a/extra/variants/variants-docs.factor b/extra/variants/variants-docs.factor new file mode 100644 index 0000000000..8ba1623f2e --- /dev/null +++ b/extra/variants/variants-docs.factor @@ -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 "" } " 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 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" diff --git a/extra/variants/variants-tests.factor b/extra/variants/variants-tests.factor new file mode 100644 index 0000000000..ef48b36b9c --- /dev/null +++ b/extra/variants/variants-tests.factor @@ -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 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 list-length ] unit-test diff --git a/extra/variants/variants.factor b/extra/variants/variants.factor new file mode 100644 index 0000000000..5cb786afde --- /dev/null +++ b/extra/variants/variants.factor @@ -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 -- ) + \ 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 ; +