Merge branch 'master' into marshall
* master: (96 commits) compiler.cfg.dataflow-analysis: iterative dataflow analysis framework functors: add MIXIN:, SINGLETON: Add assoc-refine, which takes the intersection of a sequence of assocs compiler.cfg: Fix unit tests compiler.cfg.registers: minor optimization compiler.cfg.ssa: Cytron's SSA construction algorithm compiler.cfg.dominance: fix idom computation, compute dominator tree, compute dominance frontiers, add some tests Move conjoin-at from compiler.cfg.liveness to sets sequences.abbrev: add docs - not much, but a start sequences.abbrev: keep insertion order sequences.abbrev: more small refactoring sequences.abbrev: small refactoring sequences.abbrev: Initial commit opengl is for chumps alien.inline.compiler: help-lint fix parser: remove outdated unit tests that were superseded by tests in vocabs.parser vocabs.parser: add tests to assert that the correct errors get thrown ui.tools.listener: selecting a word from a completion popup now behaves like a USE: followed by a FROM: FROM: and RENAME: give a more meaningful error if the vocabulary does not exist compiler.cfg.stack-analysis: fix outdated tests ...db4
commit
2c40a6667c
|
@ -42,9 +42,13 @@ M: bit-array set-nth-unsafe
|
|||
[ byte/bit set-bit ] 2keep
|
||||
swap n>byte set-alien-unsigned-1 ;
|
||||
|
||||
: clear-bits ( bit-array -- ) 0 (set-bits) ;
|
||||
GENERIC: clear-bits ( bit-array -- )
|
||||
|
||||
: set-bits ( bit-array -- ) -1 (set-bits) ;
|
||||
M: bit-array clear-bits 0 (set-bits) ;
|
||||
|
||||
GENERIC: set-bits ( bit-array -- )
|
||||
|
||||
M: bit-array set-bits -1 (set-bits) ;
|
||||
|
||||
M: bit-array clone
|
||||
[ length>> ] [ underlying>> clone ] bi bit-array boa ;
|
||||
|
|
|
@ -1,62 +1,46 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax io.streams.string quotations
|
||||
math ;
|
||||
math kernel ;
|
||||
IN: combinators.short-circuit
|
||||
|
||||
HELP: 0&&
|
||||
{ $values
|
||||
{ "quots" "a sequence of quotations" }
|
||||
{ "quot" quotation } }
|
||||
{ $description "Returns true if every quotation in the sequence of quotations returns true." } ;
|
||||
{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
|
||||
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
|
||||
|
||||
HELP: 0||
|
||||
{ $values
|
||||
{ "quots" "a sequence of quotations" }
|
||||
{ "quot" quotation } }
|
||||
{ $description "Returns true if any quotation in the sequence returns true." } ;
|
||||
{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the first true result, or " { $link f } } }
|
||||
{ $description "If every quotation in the sequence outputs " { $link f } ", outputs " { $link f } ", otherwise outputs the result of the first quotation that did not yield " { $link f } "." } ;
|
||||
|
||||
HELP: 1&&
|
||||
{ $values
|
||||
{ "quots" "a sequence of quotations" }
|
||||
{ "quot" quotation } }
|
||||
{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same element from the datastack and must output a boolean." } ;
|
||||
{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
|
||||
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
|
||||
|
||||
HELP: 1||
|
||||
{ $values
|
||||
{ "quots" "a sequence of quotations" }
|
||||
{ "quot" quotation } }
|
||||
{ $values { "obj" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
|
||||
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ;
|
||||
|
||||
HELP: 2&&
|
||||
{ $values
|
||||
{ "quots" "a sequence of quotations" }
|
||||
{ "quot" quotation } }
|
||||
{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same two elements from the datastack and must output a boolean." } ;
|
||||
{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
|
||||
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
|
||||
|
||||
HELP: 2||
|
||||
{ $values
|
||||
{ "quots" "a sequence of quotations" }
|
||||
{ "quot" quotation } }
|
||||
{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
|
||||
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ;
|
||||
|
||||
HELP: 3&&
|
||||
{ $values
|
||||
{ "quots" "a sequence of quotations" }
|
||||
{ "quot" quotation } }
|
||||
{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same three elements from the datastack and must output a boolean." } ;
|
||||
{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
|
||||
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
|
||||
|
||||
HELP: 3||
|
||||
{ $values
|
||||
{ "quots" "a sequence of quotations" }
|
||||
{ "quot" quotation } }
|
||||
{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
|
||||
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
|
||||
|
||||
HELP: n&&
|
||||
{ $values
|
||||
{ "quots" "a sequence of quotations" } { "N" integer }
|
||||
{ "quots" "a sequence of quotations" } { "n" integer }
|
||||
{ "quot" quotation } }
|
||||
{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ;
|
||||
{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each quotation, evaluating the result in the same manner as " { $link 0&& } "." } ;
|
||||
|
||||
HELP: n||
|
||||
{ $values
|
||||
|
|
|
@ -1,32 +1,25 @@
|
|||
|
||||
USING: kernel math tools.test combinators.short-circuit ;
|
||||
|
||||
IN: combinators.short-circuit.tests
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
[ 3 ] [ { [ 1 ] [ 2 ] [ 3 ] } 0&& ] unit-test
|
||||
[ 5 ] [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& ] unit-test
|
||||
[ 30 ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& ] unit-test
|
||||
|
||||
: must-be-t ( in -- ) [ t ] swap unit-test ;
|
||||
: must-be-f ( in -- ) [ f ] swap unit-test ;
|
||||
[ f ] [ { [ 1 ] [ f ] [ 3 ] } 0&& ] unit-test
|
||||
[ f ] [ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] unit-test
|
||||
[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& ] unit-test
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
[ "factor" ] [ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| ] unit-test
|
||||
[ 11 ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| ] unit-test
|
||||
[ 30 ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| ] unit-test
|
||||
[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] unit-test
|
||||
|
||||
[ { [ 1 ] [ 2 ] [ 3 ] } 0&& 3 = ] must-be-t
|
||||
[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& 5 = ] must-be-t
|
||||
[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& 30 = ] must-be-t
|
||||
: compiled-&& ( a -- ? ) { [ 0 > ] [ even? ] [ 2 + ] } 1&& ;
|
||||
|
||||
[ { [ 1 ] [ f ] [ 3 ] } 0&& 3 = ] must-be-f
|
||||
[ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] must-be-f
|
||||
[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& 30 = ] must-be-f
|
||||
[ f ] [ 3 compiled-&& ] unit-test
|
||||
[ 4 ] [ 2 compiled-&& ] unit-test
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
[ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| "factor" = ] must-be-t
|
||||
|
||||
[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| 11 = ] must-be-t
|
||||
|
||||
[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| 30 = ] must-be-t
|
||||
|
||||
[ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] must-be-f
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
: compiled-|| ( a b -- ? ) { [ + odd? ] [ + 100 > ] [ + ] } 2|| ;
|
||||
|
||||
[ 30 ] [ 10 20 compiled-|| ] unit-test
|
||||
[ 2 ] [ 1 1 compiled-|| ] unit-test
|
|
@ -12,10 +12,17 @@ MACRO:: n&& ( quots n -- quot )
|
|||
n '[ _ nnip ] suffix 1array
|
||||
[ cond ] 3append ;
|
||||
|
||||
MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
|
||||
MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ;
|
||||
MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
|
||||
MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
|
||||
<PRIVATE
|
||||
|
||||
: unoptimized-&& ( quots quot -- ? )
|
||||
[ [ call dup ] ] dip call [ nip ] prepose [ f ] 2dip all? swap and ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: 0&& ( quots -- ? ) [ ] unoptimized-&& ;
|
||||
: 1&& ( obj quots -- ? ) [ with ] unoptimized-&& ;
|
||||
: 2&& ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-&& ;
|
||||
: 3&& ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-&& ;
|
||||
|
||||
MACRO:: n|| ( quots n -- quot )
|
||||
[ f ] quots [| q |
|
||||
|
@ -27,7 +34,14 @@ MACRO:: n|| ( quots n -- quot )
|
|||
n '[ drop _ ndrop t ] [ f ] 2array suffix 1array
|
||||
[ cond ] 3append ;
|
||||
|
||||
MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;
|
||||
MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ;
|
||||
MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ;
|
||||
MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ;
|
||||
<PRIVATE
|
||||
|
||||
: unoptimized-|| ( quots quot -- ? )
|
||||
[ [ call ] ] dip call map-find drop ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: 0|| ( quots -- ? ) [ ] unoptimized-|| ;
|
||||
: 1|| ( obj quots -- ? ) [ with ] unoptimized-|| ;
|
||||
: 2|| ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-|| ;
|
||||
: 3|| ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-|| ;
|
||||
|
|
|
@ -0,0 +1,43 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit kernel sequences math
|
||||
compiler.utilities compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
|
||||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.block-joining
|
||||
|
||||
! Joining blocks that are not calls and are connected by a single CFG edge.
|
||||
! Predecessors must be recomputed after this. Also this pass does not
|
||||
! update ##phi nodes and should therefore only run before stack analysis.
|
||||
|
||||
: kill-vreg-block? ( bb -- ? )
|
||||
instructions>> {
|
||||
[ length 2 >= ]
|
||||
[ penultimate kill-vreg-insn? ]
|
||||
} 1&& ;
|
||||
|
||||
: predecessor ( bb -- pred )
|
||||
predecessors>> first ; inline
|
||||
|
||||
: join-block? ( bb -- ? )
|
||||
{
|
||||
[ predecessors>> length 1 = ]
|
||||
[ predecessor kill-vreg-block? not ]
|
||||
[ predecessor successors>> length 1 = ]
|
||||
[ [ predecessor ] keep back-edge? not ]
|
||||
} 1&& ;
|
||||
|
||||
: join-instructions ( bb pred -- )
|
||||
[ instructions>> ] bi@ dup pop* push-all ;
|
||||
|
||||
: update-successors ( bb pred -- )
|
||||
[ successors>> ] dip (>>successors) ;
|
||||
|
||||
: join-block ( bb pred -- )
|
||||
[ join-instructions ] [ update-successors ] 2bi ;
|
||||
|
||||
: join-blocks ( cfg -- cfg' )
|
||||
dup post-order [
|
||||
dup join-block?
|
||||
[ dup predecessor join-block ] [ drop ] if
|
||||
] each
|
||||
cfg-changed ;
|
|
@ -1,85 +0,0 @@
|
|||
IN: compiler.cfg.branch-folding.tests
|
||||
USING: compiler.cfg.branch-folding compiler.cfg.instructions
|
||||
compiler.cfg compiler.cfg.registers compiler.cfg.debugger
|
||||
arrays compiler.cfg.phi-elimination compiler.cfg.dce
|
||||
compiler.cfg.predecessors kernel accessors assocs
|
||||
sequences classes namespaces tools.test cpu.architecture ;
|
||||
|
||||
V{ T{ ##branch } } 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-immediate f V int-regs 1 1 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-immediate f V int-regs 2 2 }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##phi f V int-regs 3 { } }
|
||||
T{ ##replace f V int-regs 3 D 0 }
|
||||
T{ ##return }
|
||||
} 4 test-bb
|
||||
|
||||
4 get instructions>> first
|
||||
2 get V int-regs 1 2array
|
||||
3 get V int-regs 2 2array 2array
|
||||
>>inputs drop
|
||||
|
||||
test-diamond
|
||||
|
||||
[ ] [ cfg new 0 get >>entry fold-branches compute-predecessors eliminate-phis drop ] unit-test
|
||||
|
||||
[ 1 ] [ 1 get successors>> length ] unit-test
|
||||
[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
|
||||
|
||||
[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
|
||||
[ 2 ] [ 4 get instructions>> length ] unit-test
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##copy f V int-regs 2 V int-regs 0 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##phi f V int-regs 3 V{ } }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 3 D 0 }
|
||||
T{ ##return }
|
||||
} 4 test-bb
|
||||
|
||||
1 get V int-regs 1 2array
|
||||
2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs)
|
||||
|
||||
test-diamond
|
||||
|
||||
[ ] [
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
fold-branches
|
||||
compute-predecessors
|
||||
eliminate-dead-code
|
||||
drop
|
||||
] unit-test
|
||||
|
||||
[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test
|
|
@ -1,30 +0,0 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit kernel sequences vectors
|
||||
compiler.cfg.instructions compiler.cfg.rpo ;
|
||||
IN: compiler.cfg.branch-folding
|
||||
|
||||
! Fold comparisons where both inputs are the same. Predecessors must be
|
||||
! recomputed after this
|
||||
|
||||
: fold-branch? ( bb -- ? )
|
||||
instructions>> last {
|
||||
[ ##compare-branch? ]
|
||||
[ [ src1>> ] [ src2>> ] bi = ]
|
||||
} 1&& ;
|
||||
|
||||
: chosen-successor ( bb -- succ )
|
||||
[ instructions>> last cc>> { cc= cc<= cc>= } memq? 0 1 ? ]
|
||||
[ successors>> ]
|
||||
bi nth ;
|
||||
|
||||
: fold-branch ( bb -- )
|
||||
dup chosen-successor 1vector >>successors
|
||||
instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ;
|
||||
|
||||
: fold-branches ( cfg -- cfg' )
|
||||
dup [
|
||||
dup fold-branch?
|
||||
[ fold-branch ] [ drop ] if
|
||||
] each-basic-block
|
||||
f >>post-order ;
|
|
@ -0,0 +1,85 @@
|
|||
USING: accessors assocs compiler.cfg
|
||||
compiler.cfg.branch-splitting compiler.cfg.debugger
|
||||
compiler.cfg.predecessors compiler.cfg.rpo compiler.cfg.instructions fry kernel
|
||||
tools.test namespaces sequences vectors ;
|
||||
IN: compiler.cfg.branch-splitting.tests
|
||||
|
||||
: get-predecessors ( cfg -- assoc )
|
||||
H{ } clone [ '[ [ predecessors>> ] keep _ set-at ] each-basic-block ] keep ;
|
||||
|
||||
: check-predecessors ( cfg -- )
|
||||
[ get-predecessors ]
|
||||
[ compute-predecessors drop ]
|
||||
[ get-predecessors ] tri assert= ;
|
||||
|
||||
: check-branch-splitting ( cfg -- )
|
||||
compute-predecessors
|
||||
split-branches
|
||||
check-predecessors ;
|
||||
|
||||
: test-branch-splitting ( -- )
|
||||
cfg new 0 get >>entry check-branch-splitting ;
|
||||
|
||||
V{ T{ ##branch } } 0 test-bb
|
||||
|
||||
V{ T{ ##branch } } 1 test-bb
|
||||
|
||||
V{ T{ ##branch } } 2 test-bb
|
||||
|
||||
V{ T{ ##branch } } 3 test-bb
|
||||
|
||||
V{ T{ ##branch } } 4 test-bb
|
||||
|
||||
test-diamond
|
||||
|
||||
[ ] [ test-branch-splitting ] unit-test
|
||||
|
||||
V{ T{ ##branch } } 0 test-bb
|
||||
|
||||
V{ T{ ##branch } } 1 test-bb
|
||||
|
||||
V{ T{ ##branch } } 2 test-bb
|
||||
|
||||
V{ T{ ##branch } } 3 test-bb
|
||||
|
||||
V{ T{ ##branch } } 4 test-bb
|
||||
|
||||
V{ T{ ##branch } } 5 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
|
||||
1 get 3 get 4 get V{ } 2sequence >>successors drop
|
||||
|
||||
2 get 3 get 4 get V{ } 2sequence >>successors drop
|
||||
|
||||
[ ] [ test-branch-splitting ] unit-test
|
||||
|
||||
V{ T{ ##branch } } 0 test-bb
|
||||
|
||||
V{ T{ ##branch } } 1 test-bb
|
||||
|
||||
V{ T{ ##branch } } 2 test-bb
|
||||
|
||||
V{ T{ ##branch } } 3 test-bb
|
||||
|
||||
V{ T{ ##branch } } 4 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
|
||||
1 get 3 get 4 get V{ } 2sequence >>successors drop
|
||||
|
||||
2 get 4 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-branch-splitting ] unit-test
|
||||
|
||||
V{ T{ ##branch } } 0 test-bb
|
||||
|
||||
V{ T{ ##branch } } 1 test-bb
|
||||
|
||||
V{ T{ ##branch } } 2 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
|
||||
1 get 2 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-branch-splitting ] unit-test
|
|
@ -1,37 +1,81 @@
|
|||
! Copyright (C) 2009 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit kernel math sequences
|
||||
compiler.cfg.def-use compiler.cfg compiler.cfg.rpo ;
|
||||
USING: accessors combinators.short-circuit kernel math math.order
|
||||
sequences assocs namespaces vectors fry arrays splitting
|
||||
compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
|
||||
compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.branch-splitting
|
||||
|
||||
! Predecessors must be recomputed after this
|
||||
: clone-renamings ( insns -- assoc )
|
||||
[ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ;
|
||||
|
||||
: split-branch-for ( bb predecessor -- )
|
||||
[
|
||||
: clone-instructions ( insns -- insns' )
|
||||
dup clone-renamings renamings [
|
||||
[
|
||||
<basic-block>
|
||||
swap
|
||||
[ instructions>> [ clone ] map >>instructions ]
|
||||
[ successors>> clone >>successors ]
|
||||
bi
|
||||
] keep
|
||||
] dip
|
||||
[ [ 2dup eq? [ 2drop ] [ 2nip ] if ] with with map ] change-successors
|
||||
drop ;
|
||||
clone
|
||||
dup rename-insn-defs
|
||||
dup rename-insn-uses
|
||||
dup fresh-insn-temps
|
||||
] map
|
||||
] with-variable ;
|
||||
|
||||
: clone-basic-block ( bb -- bb' )
|
||||
! The new block gets the same RPO number as the old one.
|
||||
! This is just to make 'back-edge?' work.
|
||||
<basic-block>
|
||||
swap
|
||||
[ instructions>> clone-instructions >>instructions ]
|
||||
[ successors>> clone >>successors ]
|
||||
[ number>> >>number ]
|
||||
tri ;
|
||||
|
||||
: new-blocks ( bb -- copies )
|
||||
dup predecessors>> [
|
||||
[ clone-basic-block ] dip
|
||||
1vector >>predecessors
|
||||
] with map ;
|
||||
|
||||
: update-predecessor-successor ( pred copy old-bb -- )
|
||||
'[
|
||||
[ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map
|
||||
] change-successors drop ;
|
||||
|
||||
: update-predecessor-successors ( copies old-bb -- )
|
||||
[ predecessors>> swap ] keep
|
||||
'[ _ update-predecessor-successor ] 2each ;
|
||||
|
||||
: update-successor-predecessor ( copies old-bb succ -- )
|
||||
[
|
||||
swap 1array split swap join V{ } like
|
||||
] change-predecessors drop ;
|
||||
|
||||
: update-successor-predecessors ( copies old-bb -- )
|
||||
dup successors>> [
|
||||
update-successor-predecessor
|
||||
] with with each ;
|
||||
|
||||
: split-branch ( bb -- )
|
||||
dup predecessors>> [ split-branch-for ] with each ;
|
||||
[ new-blocks ] keep
|
||||
[ update-predecessor-successors ]
|
||||
[ update-successor-predecessors ]
|
||||
2bi ;
|
||||
|
||||
: split-branches? ( bb -- ? )
|
||||
UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
|
||||
|
||||
: split-instructions? ( insns -- ? )
|
||||
[ [ irrelevant? not ] count 5 <= ]
|
||||
[ last ##fixnum-overflow? not ]
|
||||
bi and ;
|
||||
|
||||
: split-branch? ( bb -- ? )
|
||||
{
|
||||
[ successors>> empty? ]
|
||||
[ predecessors>> length 1 > ]
|
||||
[ instructions>> [ defs-vregs ] any? not ]
|
||||
[ instructions>> [ temp-vregs ] any? not ]
|
||||
[ dup successors>> [ back-edge? ] with any? not ]
|
||||
[ predecessors>> length 2 4 between? ]
|
||||
[ instructions>> split-instructions? ]
|
||||
} 1&& ;
|
||||
|
||||
: split-branches ( cfg -- cfg' )
|
||||
dup [
|
||||
dup split-branches? [ split-branch ] [ drop ] if
|
||||
dup split-branch? [ split-branch ] [ drop ] if
|
||||
] each-basic-block
|
||||
f >>post-order ;
|
||||
cfg-changed ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces accessors math.order assocs kernel sequences
|
||||
combinators make classes words cpu.architecture
|
||||
|
@ -36,12 +36,6 @@ M: insn compute-stack-frame*
|
|||
] when ;
|
||||
|
||||
\ _spill t frame-required? set-word-prop
|
||||
\ ##fixnum-add t frame-required? set-word-prop
|
||||
\ ##fixnum-sub t frame-required? set-word-prop
|
||||
\ ##fixnum-mul t frame-required? set-word-prop
|
||||
\ ##fixnum-add-tail f frame-required? set-word-prop
|
||||
\ ##fixnum-sub-tail f frame-required? set-word-prop
|
||||
\ ##fixnum-mul-tail f frame-required? set-word-prop
|
||||
|
||||
: compute-stack-frame ( insns -- )
|
||||
frame-required? off
|
||||
|
|
|
@ -14,6 +14,7 @@ compiler.cfg.stacks
|
|||
compiler.cfg.utilities
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.intrinsics
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.stack-frame
|
||||
compiler.cfg.instructions
|
||||
compiler.alien ;
|
||||
|
@ -22,30 +23,20 @@ IN: compiler.cfg.builder
|
|||
! Convert tree SSA IR to CFG SSA IR.
|
||||
|
||||
SYMBOL: procedures
|
||||
SYMBOL: current-word
|
||||
SYMBOL: current-label
|
||||
SYMBOL: loops
|
||||
|
||||
: add-procedure ( -- )
|
||||
basic-block get current-word get current-label get
|
||||
<cfg> procedures get push ;
|
||||
|
||||
: begin-procedure ( word label -- )
|
||||
end-basic-block
|
||||
begin-basic-block
|
||||
H{ } clone loops set
|
||||
current-label set
|
||||
current-word set
|
||||
add-procedure ;
|
||||
[ basic-block get ] 2dip
|
||||
<cfg> procedures get push ;
|
||||
|
||||
: with-cfg-builder ( nodes word label quot -- )
|
||||
'[ begin-procedure @ ] with-scope ; inline
|
||||
|
||||
GENERIC: emit-node ( node -- )
|
||||
|
||||
: check-basic-block ( node -- node' )
|
||||
basic-block get [ drop f ] unless ; inline
|
||||
|
||||
: emit-nodes ( nodes -- )
|
||||
[ basic-block get [ emit-node ] [ drop ] if ] each ;
|
||||
|
||||
|
@ -97,17 +88,10 @@ M: #recursive emit-node
|
|||
|
||||
! #if
|
||||
: emit-branch ( obj -- final-bb )
|
||||
[
|
||||
begin-basic-block
|
||||
emit-nodes
|
||||
basic-block get dup [ ##branch ] when
|
||||
] with-scope ;
|
||||
[ emit-nodes ] with-branch ;
|
||||
|
||||
: emit-if ( node -- )
|
||||
children>> [ emit-branch ] map
|
||||
end-basic-block
|
||||
begin-basic-block
|
||||
basic-block get '[ [ _ swap successors>> push ] when* ] each ;
|
||||
children>> [ emit-branch ] map emit-conditional ;
|
||||
|
||||
: ##branch-t ( vreg -- )
|
||||
\ f tag-number cc/= ##compare-imm-branch ;
|
||||
|
|
|
@ -1,9 +1,6 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays vectors accessors assocs sets
|
||||
namespaces math make fry sequences
|
||||
combinators.short-circuit
|
||||
compiler.cfg.instructions ;
|
||||
USING: kernel math vectors arrays accessors namespaces ;
|
||||
IN: compiler.cfg
|
||||
|
||||
TUPLE: basic-block < identity-tuple
|
||||
|
@ -22,36 +19,12 @@ M: basic-block hashcode* nip id>> ;
|
|||
V{ } clone >>predecessors
|
||||
\ basic-block counter >>id ;
|
||||
|
||||
: empty-block? ( bb -- ? )
|
||||
instructions>> {
|
||||
[ length 1 = ]
|
||||
[ first ##branch? ]
|
||||
} 1&& ;
|
||||
|
||||
SYMBOL: visited
|
||||
|
||||
: (skip-empty-blocks) ( bb -- bb' )
|
||||
dup visited get key? [
|
||||
dup empty-block? [
|
||||
dup visited get conjoin
|
||||
successors>> first (skip-empty-blocks)
|
||||
] when
|
||||
] unless ;
|
||||
|
||||
: skip-empty-blocks ( bb -- bb' )
|
||||
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
|
||||
|
||||
: add-instructions ( bb quot -- )
|
||||
[ instructions>> building ] dip '[
|
||||
building get pop
|
||||
_ dip
|
||||
building get push
|
||||
] with-variable ; inline
|
||||
|
||||
TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
|
||||
|
||||
: <cfg> ( entry word label -- cfg ) f f cfg boa ;
|
||||
|
||||
: cfg-changed ( cfg -- cfg ) f >>post-order ; inline
|
||||
|
||||
TUPLE: mr { instructions array } word label ;
|
||||
|
||||
: <mr> ( instructions word label -- mr )
|
||||
|
|
|
@ -16,9 +16,9 @@ ERROR: last-insn-not-a-jump insn ;
|
|||
[ ##return? ]
|
||||
[ ##callback-return? ]
|
||||
[ ##jump? ]
|
||||
[ ##fixnum-add-tail? ]
|
||||
[ ##fixnum-sub-tail? ]
|
||||
[ ##fixnum-mul-tail? ]
|
||||
[ ##fixnum-add? ]
|
||||
[ ##fixnum-sub? ]
|
||||
[ ##fixnum-mul? ]
|
||||
[ ##no-tco? ]
|
||||
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
|
||||
|
||||
|
|
|
@ -0,0 +1,36 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs math.order sequences ;
|
||||
IN: compiler.cfg.comparisons
|
||||
|
||||
SYMBOLS: cc< cc<= cc= cc> cc>= cc/= ;
|
||||
|
||||
: negate-cc ( cc -- cc' )
|
||||
H{
|
||||
{ cc< cc>= }
|
||||
{ cc<= cc> }
|
||||
{ cc> cc<= }
|
||||
{ cc>= cc< }
|
||||
{ cc= cc/= }
|
||||
{ cc/= cc= }
|
||||
} at ;
|
||||
|
||||
: swap-cc ( cc -- cc' )
|
||||
H{
|
||||
{ cc< cc> }
|
||||
{ cc<= cc>= }
|
||||
{ cc> cc< }
|
||||
{ cc>= cc<= }
|
||||
{ cc= cc= }
|
||||
{ cc/= cc/= }
|
||||
} at ;
|
||||
|
||||
: evaluate-cc ( result cc -- ? )
|
||||
H{
|
||||
{ cc< { +lt+ } }
|
||||
{ cc<= { +lt+ +eq+ } }
|
||||
{ cc= { +eq+ } }
|
||||
{ cc>= { +eq+ +gt+ } }
|
||||
{ cc> { +gt+ } }
|
||||
{ cc/= { +lt+ +gt+ } }
|
||||
} at memq? ;
|
|
@ -0,0 +1,140 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs deques dlists kernel locals sequences lexer
|
||||
namespaces functors compiler.cfg.rpo compiler.cfg.utilities
|
||||
compiler.cfg ;
|
||||
IN: compiler.cfg.dataflow-analysis
|
||||
|
||||
GENERIC: join-sets ( sets dfa -- set )
|
||||
GENERIC: transfer-set ( in-set bb dfa -- out-set )
|
||||
GENERIC: block-order ( cfg dfa -- bbs )
|
||||
GENERIC: successors ( bb dfa -- seq )
|
||||
GENERIC: predecessors ( bb dfa -- seq )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
MIXIN: dataflow-analysis
|
||||
|
||||
: <dfa-worklist> ( cfg dfa -- queue )
|
||||
block-order <hashed-dlist> [ push-all-front ] keep ;
|
||||
|
||||
GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
|
||||
|
||||
M: kill-block compute-in-set 3drop f ;
|
||||
|
||||
M:: basic-block compute-in-set ( bb out-sets dfa -- set )
|
||||
bb dfa predecessors [ out-sets at ] map dfa join-sets ;
|
||||
|
||||
:: update-in-set ( bb in-sets out-sets dfa -- ? )
|
||||
bb out-sets dfa compute-in-set
|
||||
bb in-sets maybe-set-at ; inline
|
||||
|
||||
GENERIC# compute-out-set 2 ( bb out-sets dfa -- set )
|
||||
|
||||
M: kill-block compute-out-set 3drop f ;
|
||||
|
||||
M:: basic-block compute-out-set ( bb in-sets dfa -- set )
|
||||
bb in-sets at bb dfa transfer-set ;
|
||||
|
||||
:: update-out-set ( bb in-sets out-sets dfa -- ? )
|
||||
bb in-sets dfa compute-out-set
|
||||
bb out-sets maybe-set-at ; inline
|
||||
|
||||
:: dfa-step ( bb in-sets out-sets dfa work-list -- )
|
||||
bb in-sets out-sets dfa update-in-set [
|
||||
bb in-sets out-sets dfa update-out-set [
|
||||
bb dfa successors work-list push-all-front
|
||||
] when
|
||||
] when ; inline
|
||||
|
||||
:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets )
|
||||
H{ } clone :> in-sets
|
||||
H{ } clone :> out-sets
|
||||
cfg dfa <dfa-worklist> :> work-list
|
||||
work-list [ in-sets out-sets dfa work-list dfa-step ] slurp-deque
|
||||
in-sets
|
||||
out-sets ; inline
|
||||
|
||||
M: dataflow-analysis join-sets drop assoc-refine ;
|
||||
|
||||
FUNCTOR: define-analysis ( name -- )
|
||||
|
||||
name-analysis DEFINES-CLASS ${name}-analysis
|
||||
name-ins DEFINES ${name}-ins
|
||||
name-outs DEFINES ${name}-outs
|
||||
name-in DEFINES ${name}-in
|
||||
name-out DEFINES ${name}-out
|
||||
|
||||
WHERE
|
||||
|
||||
SINGLETON: name-analysis
|
||||
|
||||
SYMBOL: name-ins
|
||||
|
||||
: name-in ( bb -- set ) name-ins get at ;
|
||||
|
||||
SYMBOL: name-outs
|
||||
|
||||
: name-out ( bb -- set ) name-outs get at ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
! ! ! Forward dataflow analysis
|
||||
|
||||
MIXIN: forward-analysis
|
||||
INSTANCE: forward-analysis dataflow-analysis
|
||||
|
||||
M: forward-analysis block-order drop reverse-post-order ;
|
||||
M: forward-analysis successors drop successors>> ;
|
||||
M: forward-analysis predecessors drop predecessors>> ;
|
||||
|
||||
FUNCTOR: define-forward-analysis ( name -- )
|
||||
|
||||
name-analysis IS ${name}-analysis
|
||||
name-ins IS ${name}-ins
|
||||
name-outs IS ${name}-outs
|
||||
compute-name-sets DEFINES compute-${name}-sets
|
||||
|
||||
WHERE
|
||||
|
||||
INSTANCE: name-analysis forward-analysis
|
||||
|
||||
: compute-name-sets ( cfg -- )
|
||||
name-analysis run-dataflow-analysis
|
||||
[ name-ins set ] [ name-outs set ] bi* ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
! ! ! Backward dataflow analysis
|
||||
|
||||
MIXIN: backward-analysis
|
||||
INSTANCE: backward-analysis dataflow-analysis
|
||||
|
||||
M: backward-analysis block-order drop post-order ;
|
||||
M: backward-analysis successors drop predecessors>> ;
|
||||
M: backward-analysis predecessors drop successors>> ;
|
||||
|
||||
FUNCTOR: define-backward-analysis ( name -- )
|
||||
|
||||
name-analysis IS ${name}-analysis
|
||||
name-ins IS ${name}-ins
|
||||
name-outs IS ${name}-outs
|
||||
compute-name-sets DEFINES compute-${name}-sets
|
||||
|
||||
WHERE
|
||||
|
||||
INSTANCE: name-analysis backward-analysis
|
||||
|
||||
: compute-name-sets ( cfg -- )
|
||||
\ name-analysis run-dataflow-analysis
|
||||
[ name-outs set ] [ name-ins set ] bi* ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SYNTAX: FORWARD-ANALYSIS:
|
||||
scan [ define-analysis ] [ define-forward-analysis ] bi ;
|
||||
|
||||
SYNTAX: BACKWARD-ANALYSIS:
|
||||
scan [ define-analysis ] [ define-backward-analysis ] bi ;
|
|
@ -26,7 +26,7 @@ M: word test-cfg
|
|||
] map ;
|
||||
|
||||
: insn. ( insn -- )
|
||||
tuple>array [ pprint bl ] each nl ;
|
||||
tuple>array but-last [ pprint bl ] each nl ;
|
||||
|
||||
: mr. ( mrs -- )
|
||||
[
|
||||
|
|
|
@ -8,6 +8,7 @@ GENERIC: temp-vregs ( insn -- seq )
|
|||
GENERIC: uses-vregs ( insn -- seq )
|
||||
|
||||
M: ##flushable defs-vregs dst>> 1array ;
|
||||
M: ##fixnum-overflow defs-vregs dst>> 1array ;
|
||||
M: insn defs-vregs drop f ;
|
||||
|
||||
M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
|
||||
|
@ -21,8 +22,6 @@ M: ##set-string-nth-fast temp-vregs temp>> 1array ;
|
|||
M: ##compare temp-vregs temp>> 1array ;
|
||||
M: ##compare-imm temp-vregs temp>> 1array ;
|
||||
M: ##compare-float temp-vregs temp>> 1array ;
|
||||
M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
|
||||
M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
|
||||
M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
|
||||
M: _dispatch temp-vregs temp>> 1array ;
|
||||
M: insn temp-vregs drop f ;
|
||||
|
|
|
@ -0,0 +1,76 @@
|
|||
IN: compiler.cfg.dominance.tests
|
||||
USING: tools.test sequences vectors namespaces kernel accessors assocs sets
|
||||
math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger
|
||||
compiler.cfg.predecessors ;
|
||||
|
||||
: test-dominance ( -- )
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
compute-dominance
|
||||
drop ;
|
||||
|
||||
! Example with no back edges
|
||||
V{ } 0 test-bb
|
||||
V{ } 1 test-bb
|
||||
V{ } 2 test-bb
|
||||
V{ } 3 test-bb
|
||||
V{ } 4 test-bb
|
||||
V{ } 5 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
1 get 3 get 1vector >>successors drop
|
||||
2 get 4 get 1vector >>successors drop
|
||||
3 get 4 get 1vector >>successors drop
|
||||
4 get 5 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-dominance ] unit-test
|
||||
|
||||
[ t ] [ 0 get dom-parent 0 get eq? ] unit-test
|
||||
[ t ] [ 1 get dom-parent 0 get eq? ] unit-test
|
||||
[ t ] [ 2 get dom-parent 0 get eq? ] unit-test
|
||||
[ t ] [ 4 get dom-parent 0 get eq? ] unit-test
|
||||
[ t ] [ 3 get dom-parent 1 get eq? ] unit-test
|
||||
[ t ] [ 5 get dom-parent 4 get eq? ] unit-test
|
||||
|
||||
[ t ] [ 0 get dom-children 1 get 2 get 4 get 3array set= ] unit-test
|
||||
|
||||
[ { 4 } ] [ 1 get dom-frontier [ number>> ] map ] unit-test
|
||||
[ { 4 } ] [ 2 get dom-frontier [ number>> ] map ] unit-test
|
||||
[ { } ] [ 0 get dom-frontier ] unit-test
|
||||
[ { } ] [ 4 get dom-frontier ] unit-test
|
||||
|
||||
! Example from the paper
|
||||
V{ } 0 test-bb
|
||||
V{ } 1 test-bb
|
||||
V{ } 2 test-bb
|
||||
V{ } 3 test-bb
|
||||
V{ } 4 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
1 get 3 get 1vector >>successors drop
|
||||
2 get 4 get 1vector >>successors drop
|
||||
3 get 4 get 1vector >>successors drop
|
||||
4 get 3 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-dominance ] unit-test
|
||||
|
||||
[ t ] [ 0 4 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test
|
||||
|
||||
! The other example from the paper
|
||||
V{ } 0 test-bb
|
||||
V{ } 1 test-bb
|
||||
V{ } 2 test-bb
|
||||
V{ } 3 test-bb
|
||||
V{ } 4 test-bb
|
||||
V{ } 5 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
1 get 5 get 1vector >>successors drop
|
||||
2 get 4 get 3 get V{ } 2sequence >>successors drop
|
||||
5 get 4 get 1vector >>successors drop
|
||||
4 get 5 get 3 get V{ } 2sequence >>successors drop
|
||||
3 get 4 get 1vector >>successors drop
|
||||
|
||||
[ ] [ test-dominance ] unit-test
|
||||
|
||||
[ t ] [ 0 5 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test
|
|
@ -1,8 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs combinators compiler.cfg.rpo
|
||||
compiler.cfg.stack-analysis fry kernel math.order namespaces
|
||||
sequences ;
|
||||
USING: accessors assocs combinators sets math fry kernel math.order
|
||||
namespaces sequences sorting compiler.cfg.rpo ;
|
||||
IN: compiler.cfg.dominance
|
||||
|
||||
! Reference:
|
||||
|
@ -11,31 +10,83 @@ IN: compiler.cfg.dominance
|
|||
! Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy
|
||||
! http://www.cs.rice.edu/~keith/EMBED/dom.pdf
|
||||
|
||||
SYMBOL: idoms
|
||||
|
||||
: idom ( bb -- bb' ) idoms get at ;
|
||||
! Also, a nice overview is given in these lecture notes:
|
||||
! http://llvm.cs.uiuc.edu/~vadve/CS526/public_html/Notes/4ssa.4up.pdf
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: set-idom ( idom bb -- changed? ) idoms get maybe-set-at ;
|
||||
! Maps bb -> idom(bb)
|
||||
SYMBOL: dom-parents
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: dom-parent ( bb -- bb' ) dom-parents get at ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: set-idom ( idom bb -- changed? )
|
||||
dom-parents get maybe-set-at ;
|
||||
|
||||
: intersect ( finger1 finger2 -- bb )
|
||||
2dup [ number>> ] compare {
|
||||
{ +lt+ [ [ idom ] dip intersect ] }
|
||||
{ +gt+ [ idom intersect ] }
|
||||
{ +gt+ [ [ dom-parent ] dip intersect ] }
|
||||
{ +lt+ [ dom-parent intersect ] }
|
||||
[ 2drop ]
|
||||
} case ;
|
||||
|
||||
: compute-idom ( bb -- idom )
|
||||
predecessors>> [ idom ] map sift
|
||||
predecessors>> [ dom-parent ] filter
|
||||
[ ] [ intersect ] map-reduce ;
|
||||
|
||||
: iterate ( rpo -- changed? )
|
||||
[ [ compute-idom ] keep set-idom ] map [ ] any? ;
|
||||
|
||||
: compute-dom-parents ( cfg -- )
|
||||
H{ } clone dom-parents set
|
||||
reverse-post-order
|
||||
unclip dup set-idom drop '[ _ iterate ] loop ;
|
||||
|
||||
! Maps bb -> {bb' | idom(bb') = bb}
|
||||
SYMBOL: dom-childrens
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: compute-dominance ( cfg -- cfg )
|
||||
H{ } clone idoms set
|
||||
dup reverse-post-order
|
||||
unclip dup set-idom drop '[ _ iterate ] loop ;
|
||||
: dom-children ( bb -- seq ) dom-childrens get at ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: compute-dom-children ( -- )
|
||||
dom-parents get H{ } clone
|
||||
[ '[ 2dup eq? [ 2drop ] [ _ push-at ] if ] assoc-each ] keep
|
||||
dom-childrens set ;
|
||||
|
||||
! Maps bb -> DF(bb)
|
||||
SYMBOL: dom-frontiers
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: dom-frontier ( bb -- set ) dom-frontiers get at keys ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: compute-dom-frontier ( bb pred -- )
|
||||
2dup [ dom-parent ] dip eq? [ 2drop ] [
|
||||
[ dom-frontiers get conjoin-at ]
|
||||
[ dom-parent compute-dom-frontier ] 2bi
|
||||
] if ;
|
||||
|
||||
: compute-dom-frontiers ( cfg -- )
|
||||
H{ } clone dom-frontiers set
|
||||
[
|
||||
dup predecessors>> dup length 2 >= [
|
||||
[ compute-dom-frontier ] with each
|
||||
] [ 2drop ] if
|
||||
] each-basic-block ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: compute-dominance ( cfg -- cfg' )
|
||||
[ compute-dom-parents compute-dom-children ]
|
||||
[ compute-dom-frontiers ]
|
||||
[ ]
|
||||
tri ;
|
||||
|
|
|
@ -27,6 +27,7 @@ IN: compiler.cfg.hats
|
|||
: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
|
||||
: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
|
||||
: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline
|
||||
: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline
|
||||
: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline
|
||||
: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline
|
||||
: ^^and ( input mask -- output ) ^^i2 ##and ; inline
|
||||
|
@ -35,8 +36,11 @@ IN: compiler.cfg.hats
|
|||
: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline
|
||||
: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline
|
||||
: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline
|
||||
: ^^shl ( src1 src2 -- dst ) ^^i2 ##shl ; inline
|
||||
: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline
|
||||
: ^^shr ( src1 src2 -- dst ) ^^i2 ##shr ; inline
|
||||
: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
|
||||
: ^^sar ( src1 src2 -- dst ) ^^i2 ##sar ; inline
|
||||
: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
|
||||
: ^^not ( src -- dst ) ^^i1 ##not ; inline
|
||||
: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline
|
||||
|
@ -73,5 +77,7 @@ IN: compiler.cfg.hats
|
|||
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
|
||||
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
|
||||
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
|
||||
|
||||
: ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline
|
||||
: ^^fixnum-sub ( src1 src2 -- dst ) ^^i2 ##fixnum-sub ; inline
|
||||
: ^^fixnum-mul ( src1 src2 -- dst ) ^^i2 ##fixnum-mul ; inline
|
||||
: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline
|
|
@ -86,21 +86,15 @@ INSN: ##or < ##commutative ;
|
|||
INSN: ##or-imm < ##commutative-imm ;
|
||||
INSN: ##xor < ##commutative ;
|
||||
INSN: ##xor-imm < ##commutative-imm ;
|
||||
INSN: ##shl < ##binary ;
|
||||
INSN: ##shl-imm < ##binary-imm ;
|
||||
INSN: ##shr < ##binary ;
|
||||
INSN: ##shr-imm < ##binary-imm ;
|
||||
INSN: ##sar < ##binary ;
|
||||
INSN: ##sar-imm < ##binary-imm ;
|
||||
INSN: ##not < ##unary ;
|
||||
INSN: ##log2 < ##unary ;
|
||||
|
||||
! Overflowing arithmetic
|
||||
TUPLE: ##fixnum-overflow < insn src1 src2 ;
|
||||
INSN: ##fixnum-add < ##fixnum-overflow ;
|
||||
INSN: ##fixnum-add-tail < ##fixnum-overflow ;
|
||||
INSN: ##fixnum-sub < ##fixnum-overflow ;
|
||||
INSN: ##fixnum-sub-tail < ##fixnum-overflow ;
|
||||
INSN: ##fixnum-mul < ##fixnum-overflow temp1 temp2 ;
|
||||
INSN: ##fixnum-mul-tail < ##fixnum-overflow temp1 temp2 ;
|
||||
|
||||
: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
|
||||
: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
|
||||
|
||||
|
@ -181,44 +175,7 @@ INSN: ##loop-entry ;
|
|||
|
||||
INSN: ##phi < ##pure inputs ;
|
||||
|
||||
! Condition codes
|
||||
SYMBOL: cc<
|
||||
SYMBOL: cc<=
|
||||
SYMBOL: cc=
|
||||
SYMBOL: cc>
|
||||
SYMBOL: cc>=
|
||||
SYMBOL: cc/=
|
||||
|
||||
: negate-cc ( cc -- cc' )
|
||||
H{
|
||||
{ cc< cc>= }
|
||||
{ cc<= cc> }
|
||||
{ cc> cc<= }
|
||||
{ cc>= cc< }
|
||||
{ cc= cc/= }
|
||||
{ cc/= cc= }
|
||||
} at ;
|
||||
|
||||
: swap-cc ( cc -- cc' )
|
||||
H{
|
||||
{ cc< cc> }
|
||||
{ cc<= cc>= }
|
||||
{ cc> cc< }
|
||||
{ cc>= cc<= }
|
||||
{ cc= cc= }
|
||||
{ cc/= cc/= }
|
||||
} at ;
|
||||
|
||||
: evaluate-cc ( result cc -- ? )
|
||||
H{
|
||||
{ cc< { +lt+ } }
|
||||
{ cc<= { +lt+ +eq+ } }
|
||||
{ cc= { +eq+ } }
|
||||
{ cc>= { +eq+ +gt+ } }
|
||||
{ cc> { +gt+ } }
|
||||
{ cc/= { +lt+ +gt+ } }
|
||||
} at memq? ;
|
||||
|
||||
! Conditionals
|
||||
TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
|
||||
|
||||
INSN: ##compare-branch < ##conditional-branch ;
|
||||
|
@ -230,6 +187,12 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
|
|||
INSN: ##compare-float-branch < ##conditional-branch ;
|
||||
INSN: ##compare-float < ##binary cc temp ;
|
||||
|
||||
! Overflowing arithmetic
|
||||
TUPLE: ##fixnum-overflow < insn { dst vreg } { src1 vreg } { src2 vreg } ;
|
||||
INSN: ##fixnum-add < ##fixnum-overflow ;
|
||||
INSN: ##fixnum-sub < ##fixnum-overflow ;
|
||||
INSN: ##fixnum-mul < ##fixnum-overflow ;
|
||||
|
||||
INSN: ##gc { temp1 vreg } { temp2 vreg } live-values ;
|
||||
|
||||
! Instructions used by machine IR only.
|
||||
|
@ -250,6 +213,12 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
|
|||
|
||||
INSN: _compare-float-branch < _conditional-branch ;
|
||||
|
||||
! Overflowing arithmetic
|
||||
TUPLE: _fixnum-overflow < insn label { dst vreg } { src1 vreg } { src2 vreg } ;
|
||||
INSN: _fixnum-add < _fixnum-overflow ;
|
||||
INSN: _fixnum-sub < _fixnum-overflow ;
|
||||
INSN: _fixnum-mul < _fixnum-overflow ;
|
||||
|
||||
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
|
||||
|
||||
INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
|
||||
|
@ -261,3 +230,19 @@ INSN: _reload dst class n ;
|
|||
INSN: _copy dst src class ;
|
||||
INSN: _spill-counts counts ;
|
||||
|
||||
! Instructions that poison the stack state
|
||||
UNION: poison-insn
|
||||
##jump
|
||||
##return
|
||||
##callback-return ;
|
||||
|
||||
! Instructions that kill all live vregs
|
||||
UNION: kill-vreg-insn
|
||||
poison-insn
|
||||
##stack-frame
|
||||
##call
|
||||
##prologue
|
||||
##epilogue
|
||||
##alien-invoke
|
||||
##alien-indirect
|
||||
##alien-callback ;
|
||||
|
|
|
@ -1,13 +1,14 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences accessors layouts kernel math namespaces
|
||||
combinators fry locals
|
||||
USING: sequences accessors layouts kernel math math.intervals
|
||||
namespaces combinators fry arrays
|
||||
compiler.tree.propagation.info
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.stacks
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.registers ;
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.comparisons ;
|
||||
IN: compiler.cfg.intrinsics.fixnum
|
||||
|
||||
: emit-both-fixnums? ( -- )
|
||||
|
@ -20,44 +21,27 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
: tag-literal ( n -- tagged )
|
||||
literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
|
||||
|
||||
: emit-fixnum-imm-op1 ( infos insn -- dst )
|
||||
[ ds-pop ds-drop ] [ first tag-literal ] [ ] tri* call ; inline
|
||||
: emit-fixnum-op ( insn -- )
|
||||
[ 2inputs ] dip call ds-push ; inline
|
||||
|
||||
: emit-fixnum-imm-op2 ( infos insn -- dst )
|
||||
[ ds-drop ds-pop ] [ second tag-literal ] [ ] tri* call ; inline
|
||||
: emit-fixnum-left-shift ( -- )
|
||||
[ ^^untag-fixnum ^^shl ] emit-fixnum-op ;
|
||||
|
||||
: (emit-fixnum-op) ( insn -- dst )
|
||||
[ 2inputs ] dip call ; inline
|
||||
: emit-fixnum-right-shift ( -- )
|
||||
[ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ;
|
||||
|
||||
:: emit-fixnum-op ( node insn imm-insn -- )
|
||||
[let | infos [ node node-input-infos ] |
|
||||
infos second value-info-small-tagged?
|
||||
[ infos imm-insn emit-fixnum-imm-op2 ]
|
||||
[ insn (emit-fixnum-op) ] if
|
||||
ds-push
|
||||
] ; inline
|
||||
|
||||
:: emit-commutative-fixnum-op ( node insn imm-insn -- )
|
||||
[let | infos [ node node-input-infos ] |
|
||||
{
|
||||
{ [ infos first value-info-small-tagged? ] [ infos imm-insn emit-fixnum-imm-op1 ] }
|
||||
{ [ infos second value-info-small-tagged? ] [ infos imm-insn emit-fixnum-imm-op2 ] }
|
||||
[ insn (emit-fixnum-op) ]
|
||||
} cond
|
||||
ds-push
|
||||
] ; inline
|
||||
: emit-fixnum-shift-general ( -- )
|
||||
D 0 ^^peek 0 cc> ##compare-imm-branch
|
||||
[ emit-fixnum-left-shift ] with-branch
|
||||
[ emit-fixnum-right-shift ] with-branch
|
||||
2array emit-conditional ;
|
||||
|
||||
: emit-fixnum-shift-fast ( node -- )
|
||||
dup node-input-infos dup second value-info-small-fixnum? [
|
||||
nip
|
||||
[ ds-drop ds-pop ] dip
|
||||
second literal>> dup sgn {
|
||||
{ -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
|
||||
{ 0 [ drop ] }
|
||||
{ 1 [ ^^shl-imm ] }
|
||||
} case
|
||||
ds-push
|
||||
] [ drop emit-primitive ] if ;
|
||||
node-input-infos second interval>> {
|
||||
{ [ dup 0 [a,inf] interval-subset? ] [ drop emit-fixnum-left-shift ] }
|
||||
{ [ dup 0 [-inf,a] interval-subset? ] [ drop emit-fixnum-right-shift ] }
|
||||
[ drop emit-fixnum-shift-general ]
|
||||
} cond ;
|
||||
|
||||
: emit-fixnum-bitnot ( -- )
|
||||
ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
|
||||
|
@ -65,34 +49,11 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
: emit-fixnum-log2 ( -- )
|
||||
ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
|
||||
|
||||
: (emit-fixnum*fast) ( -- dst )
|
||||
2inputs ^^untag-fixnum ^^mul ;
|
||||
: emit-fixnum*fast ( -- )
|
||||
2inputs ^^untag-fixnum ^^mul ds-push ;
|
||||
|
||||
: (emit-fixnum*fast-imm1) ( infos -- dst )
|
||||
[ ds-pop ds-drop ] [ first literal>> ] bi* ^^mul-imm ;
|
||||
|
||||
: (emit-fixnum*fast-imm2) ( infos -- dst )
|
||||
[ ds-drop ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
|
||||
|
||||
: emit-fixnum*fast ( node -- )
|
||||
node-input-infos
|
||||
dup first value-info-small-fixnum? drop f
|
||||
[
|
||||
(emit-fixnum*fast-imm1)
|
||||
] [
|
||||
dup second value-info-small-fixnum?
|
||||
[ (emit-fixnum*fast-imm2) ] [ drop (emit-fixnum*fast) ] if
|
||||
] if
|
||||
ds-push ;
|
||||
|
||||
: (emit-fixnum-comparison) ( cc -- quot1 quot2 )
|
||||
[ ^^compare ] [ ^^compare-imm ] bi-curry ; inline
|
||||
|
||||
: emit-eq ( node -- )
|
||||
cc= (emit-fixnum-comparison) emit-commutative-fixnum-op ;
|
||||
|
||||
: emit-fixnum-comparison ( node cc -- )
|
||||
(emit-fixnum-comparison) emit-fixnum-op ;
|
||||
: emit-fixnum-comparison ( cc -- )
|
||||
'[ _ ^^compare ] emit-fixnum-op ;
|
||||
|
||||
: emit-bignum>fixnum ( -- )
|
||||
ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
|
||||
|
@ -100,6 +61,28 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
: emit-fixnum>bignum ( -- )
|
||||
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
|
||||
|
||||
: emit-fixnum-overflow-op ( quot -- next )
|
||||
[ 2inputs 1 ##inc-d ] dip call ##branch
|
||||
begin-basic-block ; inline
|
||||
: emit-no-overflow-case ( dst -- final-bb )
|
||||
[ -2 ##inc-d ds-push ] with-branch ;
|
||||
|
||||
: emit-overflow-case ( word -- final-bb )
|
||||
[ ##call ] with-branch ;
|
||||
|
||||
: emit-fixnum-overflow-op ( quot word -- )
|
||||
[ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip
|
||||
[ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
|
||||
emit-conditional ; inline
|
||||
|
||||
: fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ;
|
||||
|
||||
: fixnum-overflow ( x y -- z ) [ >bignum ] bi@ - ;
|
||||
|
||||
: fixnum*overflow ( x y -- z ) [ >bignum ] bi@ * ;
|
||||
|
||||
: emit-fixnum+ ( -- )
|
||||
[ ^^fixnum-add ] \ fixnum+overflow emit-fixnum-overflow-op ;
|
||||
|
||||
: emit-fixnum- ( -- )
|
||||
[ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ;
|
||||
|
||||
: emit-fixnum* ( -- )
|
||||
[ ^^untag-fixnum ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;
|
|
@ -8,7 +8,8 @@ compiler.cfg.intrinsics.allot
|
|||
compiler.cfg.intrinsics.fixnum
|
||||
compiler.cfg.intrinsics.float
|
||||
compiler.cfg.intrinsics.slots
|
||||
compiler.cfg.intrinsics.misc ;
|
||||
compiler.cfg.intrinsics.misc
|
||||
compiler.cfg.comparisons ;
|
||||
QUALIFIED: kernel
|
||||
QUALIFIED: arrays
|
||||
QUALIFIED: byte-arrays
|
||||
|
@ -40,8 +41,8 @@ IN: compiler.cfg.intrinsics
|
|||
math.private:fixnum<=
|
||||
math.private:fixnum>=
|
||||
math.private:fixnum>
|
||||
math.private:bignum>fixnum
|
||||
math.private:fixnum>bignum
|
||||
! math.private:bignum>fixnum
|
||||
! math.private:fixnum>bignum
|
||||
kernel:eq?
|
||||
slots.private:slot
|
||||
slots.private:set-slot
|
||||
|
@ -99,23 +100,23 @@ IN: compiler.cfg.intrinsics
|
|||
{ \ kernel.private:tag [ drop emit-tag ] }
|
||||
{ \ kernel.private:getenv [ emit-getenv ] }
|
||||
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
|
||||
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] emit-fixnum-overflow-op ] }
|
||||
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] emit-fixnum-overflow-op ] }
|
||||
{ \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] emit-fixnum-overflow-op ] }
|
||||
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-commutative-fixnum-op ] }
|
||||
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op ] }
|
||||
{ \ math.private:fixnum+ [ drop emit-fixnum+ ] }
|
||||
{ \ math.private:fixnum- [ drop emit-fixnum- ] }
|
||||
{ \ math.private:fixnum* [ drop emit-fixnum* ] }
|
||||
{ \ math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
|
||||
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
|
||||
{ \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
|
||||
{ \ math.private:fixnum*fast [ emit-fixnum*fast ] }
|
||||
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
|
||||
{ \ kernel:eq? [ emit-eq ] }
|
||||
{ \ math.private:fixnum*fast [ drop emit-fixnum*fast ] }
|
||||
{ \ math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
|
||||
{ \ kernel:eq? [ drop cc= emit-fixnum-comparison ] }
|
||||
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
|
||||
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
|
||||
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences
|
||||
USING: accessors kernel sequences namespaces assocs fry
|
||||
combinators.short-circuit
|
||||
compiler.cfg.linear-scan.live-intervals
|
||||
compiler.cfg.linear-scan.allocation.state ;
|
||||
|
@ -20,9 +20,16 @@ IN: compiler.cfg.linear-scan.allocation.coalescing
|
|||
[ avoids-inactive-intervals? ]
|
||||
} 1&& ;
|
||||
|
||||
: reuse-spill-slot ( old new -- )
|
||||
[ vreg>> spill-slots get at ] dip '[ _ vreg>> spill-slots get set-at ] when* ;
|
||||
|
||||
: reuse-register ( old new -- )
|
||||
reg>> >>reg drop ;
|
||||
|
||||
: (coalesce) ( old new -- )
|
||||
[ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ;
|
||||
|
||||
: coalesce ( live-interval -- )
|
||||
dup copy-from>> active-interval
|
||||
[ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
|
||||
[ reg>> >>reg drop ]
|
||||
2bi ;
|
||||
[ reuse-spill-slot ] [ reuse-register ] [ (coalesce) ] 2tri ;
|
||||
|
|
@ -17,7 +17,7 @@ ERROR: bad-live-ranges interval ;
|
|||
] [ drop ] if ;
|
||||
|
||||
: trim-before-ranges ( live-interval -- )
|
||||
[ ranges>> ] [ uses>> last ] bi
|
||||
[ ranges>> ] [ uses>> last 1 + ] bi
|
||||
[ '[ from>> _ <= ] filter-here ]
|
||||
[ swap last (>>to) ]
|
||||
2bi ;
|
||||
|
|
|
@ -19,7 +19,7 @@ IN: compiler.cfg.linear-scan.assignment
|
|||
SYMBOL: pending-intervals
|
||||
|
||||
: add-active ( live-interval -- )
|
||||
pending-intervals get push ;
|
||||
dup end>> pending-intervals get heap-push ;
|
||||
|
||||
! Minheap of live intervals which still need a register allocation
|
||||
SYMBOL: unhandled-intervals
|
||||
|
@ -37,7 +37,7 @@ SYMBOL: register-live-ins
|
|||
SYMBOL: register-live-outs
|
||||
|
||||
: init-assignment ( live-intervals -- )
|
||||
V{ } clone pending-intervals set
|
||||
<min-heap> pending-intervals set
|
||||
<min-heap> unhandled-intervals set
|
||||
H{ } clone register-live-ins set
|
||||
H{ } clone register-live-outs set
|
||||
|
@ -61,12 +61,17 @@ SYMBOL: register-live-outs
|
|||
register->register
|
||||
] [ drop ] if ;
|
||||
|
||||
: (expire-old-intervals) ( n heap -- )
|
||||
dup heap-empty? [ 2drop ] [
|
||||
2dup heap-peek nip <= [ 2drop ] [
|
||||
dup heap-pop drop [ handle-spill ] [ handle-copy ] bi
|
||||
(expire-old-intervals)
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: expire-old-intervals ( n -- )
|
||||
[
|
||||
[ pending-intervals get ] dip '[
|
||||
dup end>> _ <
|
||||
[ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
|
||||
] filter-here
|
||||
pending-intervals get (expire-old-intervals)
|
||||
] { } make mapping-instructions % ;
|
||||
|
||||
: insert-reload ( live-interval -- )
|
||||
|
@ -111,14 +116,12 @@ ERROR: overlapping-registers intervals ;
|
|||
dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ;
|
||||
|
||||
: active-intervals ( n -- intervals )
|
||||
pending-intervals get [ covers? ] with filter
|
||||
pending-intervals get heap-values [ covers? ] with filter
|
||||
check-assignment? get [ dup check-assignment ] when ;
|
||||
|
||||
M: vreg-insn assign-registers-in-insn
|
||||
dup [ all-vregs ] [ insn#>> active-intervals ] bi
|
||||
'[ _ [ vreg>> = ] with find nip ] map
|
||||
register-mapping
|
||||
>>regs drop ;
|
||||
dup [ all-vregs ] [ insn#>> active-intervals register-mapping ] bi
|
||||
extract-keys >>regs drop ;
|
||||
|
||||
M: ##gc assign-registers-in-insn
|
||||
! This works because ##gc is always the first instruction
|
||||
|
@ -150,7 +153,7 @@ ERROR: bad-live-values live-values ;
|
|||
|
||||
: begin-block ( bb -- )
|
||||
dup basic-block set
|
||||
dup block-from prepare-insn
|
||||
dup block-from activate-new-intervals
|
||||
[ [ live-in ] [ block-from ] bi compute-live-values ] keep
|
||||
register-live-ins get set-at ;
|
||||
|
||||
|
|
|
@ -12,6 +12,7 @@ compiler.cfg.predecessors
|
|||
compiler.cfg.rpo
|
||||
compiler.cfg.linearization
|
||||
compiler.cfg.debugger
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.linear-scan
|
||||
compiler.cfg.linear-scan.numbering
|
||||
compiler.cfg.linear-scan.live-intervals
|
||||
|
@ -82,9 +83,9 @@ check-numbering? on
|
|||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 1 }
|
||||
{ end 2 }
|
||||
{ uses V{ 0 1 } }
|
||||
{ ranges V{ T{ live-range f 0 1 } } }
|
||||
{ ranges V{ T{ live-range f 0 2 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
|
@ -107,9 +108,9 @@ check-numbering? on
|
|||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 0 }
|
||||
{ end 1 }
|
||||
{ uses V{ 0 } }
|
||||
{ ranges V{ T{ live-range f 0 0 } } }
|
||||
{ ranges V{ T{ live-range f 0 1 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
|
@ -132,9 +133,9 @@ check-numbering? on
|
|||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 0 }
|
||||
{ end 1 }
|
||||
{ uses V{ 0 } }
|
||||
{ ranges V{ T{ live-range f 0 0 } } }
|
||||
{ ranges V{ T{ live-range f 0 1 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
|
@ -384,7 +385,7 @@ SYMBOL: max-uses
|
|||
[
|
||||
\ live-interval new
|
||||
swap int-regs swap vreg boa >>vreg
|
||||
max-uses get random 2 max [ not-taken ] replicate natural-sort
|
||||
max-uses get random 2 max [ not-taken 2 * ] replicate natural-sort
|
||||
[ >>uses ] [ first >>start ] bi
|
||||
dup uses>> last >>end
|
||||
dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
|
||||
|
@ -1317,38 +1318,6 @@ USING: math.private ;
|
|||
allocate-registers drop
|
||||
] unit-test
|
||||
|
||||
! Spill slot liveness was computed incorrectly, leading to a FEP
|
||||
! early in bootstrap on x86-32
|
||||
[ t ] [
|
||||
[
|
||||
H{ } clone live-ins set
|
||||
H{ } clone live-outs set
|
||||
H{ } clone phi-live-ins set
|
||||
T{ basic-block
|
||||
{ id 12345 }
|
||||
{ instructions
|
||||
V{
|
||||
T{ ##gc f V int-regs 6 V int-regs 7 }
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##peek f V int-regs 2 D 2 }
|
||||
T{ ##peek f V int-regs 3 D 3 }
|
||||
T{ ##peek f V int-regs 4 D 4 }
|
||||
T{ ##peek f V int-regs 5 D 5 }
|
||||
T{ ##replace f V int-regs 0 D 1 }
|
||||
T{ ##replace f V int-regs 1 D 2 }
|
||||
T{ ##replace f V int-regs 2 D 3 }
|
||||
T{ ##replace f V int-regs 3 D 4 }
|
||||
T{ ##replace f V int-regs 4 D 5 }
|
||||
T{ ##replace f V int-regs 5 D 0 }
|
||||
}
|
||||
}
|
||||
} dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
|
||||
instructions>> first
|
||||
live-values>> assoc-empty?
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
T{ live-range f 0 10 }
|
||||
T{ live-range f 20 30 }
|
||||
|
@ -1541,6 +1510,7 @@ SYMBOL: linear-scan-result
|
|||
compute-liveness
|
||||
dup reverse-post-order
|
||||
{ { int-regs regs } } (linear-scan)
|
||||
cfg-changed
|
||||
flatten-cfg 1array mr.
|
||||
] with-scope ;
|
||||
|
||||
|
@ -1802,7 +1772,8 @@ test-diamond
|
|||
2 get instructions>> first regs>> V int-regs 1 swap at assert=
|
||||
] unit-test
|
||||
|
||||
[ _copy ] [ 3 get instructions>> second class ] unit-test
|
||||
! Not until splitting is finished
|
||||
! [ _copy ] [ 3 get instructions>> second class ] unit-test
|
||||
|
||||
! Resolve pass; make sure the spilling is done correctly
|
||||
V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb
|
||||
|
@ -1834,7 +1805,7 @@ test-diamond
|
|||
|
||||
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
[ _spill ] [ 2 get instructions>> first class ] unit-test
|
||||
[ _spill ] [ 2 get successors>> first instructions>> first class ] unit-test
|
||||
|
||||
[ _spill ] [ 3 get instructions>> second class ] unit-test
|
||||
|
||||
|
@ -1890,7 +1861,7 @@ V{
|
|||
|
||||
[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test
|
||||
|
||||
[ t ] [ 3 get instructions>> [ _spill? ] any? ] unit-test
|
||||
[ t ] [ 3 get predecessors>> first instructions>> [ _spill? ] any? ] unit-test
|
||||
|
||||
[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test
|
||||
|
||||
|
@ -1957,7 +1928,7 @@ V{
|
|||
[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test
|
||||
|
||||
! Resolve pass should insert this
|
||||
[ _reload ] [ 5 get instructions>> first class ] unit-test
|
||||
[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test
|
||||
|
||||
! Some random bug
|
||||
V{
|
||||
|
@ -2188,12 +2159,7 @@ V{
|
|||
T{ ##replace { src V int-regs 85 } { loc D 1 } }
|
||||
T{ ##replace { src V int-regs 89 } { loc D 4 } }
|
||||
T{ ##replace { src V int-regs 96 } { loc R 0 } }
|
||||
T{ ##fixnum-mul
|
||||
{ src1 V int-regs 128 }
|
||||
{ src2 V int-regs 129 }
|
||||
{ temp1 V int-regs 132 }
|
||||
{ temp2 V int-regs 133 }
|
||||
}
|
||||
T{ ##replace { src V int-regs 129 } { loc R 0 } }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
|
@ -2284,202 +2250,159 @@ V{
|
|||
|
||||
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
! Another push-all reduction to demonstrate numbering anamoly
|
||||
V{ T{ ##prologue } T{ ##branch } }
|
||||
0 test-bb
|
||||
! Fencepost error in assignment pass
|
||||
V{ T{ ##branch } } 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek { dst V int-regs 1 } { loc D 0 } }
|
||||
T{ ##slot-imm
|
||||
{ dst V int-regs 5 }
|
||||
{ obj V int-regs 1 }
|
||||
{ slot 3 }
|
||||
{ tag 7 }
|
||||
}
|
||||
T{ ##peek { dst V int-regs 7 } { loc D 1 } }
|
||||
T{ ##slot-imm
|
||||
{ dst V int-regs 12 }
|
||||
{ obj V int-regs 7 }
|
||||
{ slot 1 }
|
||||
{ tag 6 }
|
||||
}
|
||||
T{ ##add
|
||||
{ dst V int-regs 25 }
|
||||
{ src1 V int-regs 5 }
|
||||
{ src2 V int-regs 12 }
|
||||
}
|
||||
T{ ##compare-branch
|
||||
{ src1 V int-regs 25 }
|
||||
{ src2 V int-regs 5 }
|
||||
{ cc cc> }
|
||||
}
|
||||
}
|
||||
1 test-bb
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##compare-imm-branch f V int-regs 0 5 cc= }
|
||||
} 1 test-bb
|
||||
|
||||
V{ T{ ##branch } } 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##slot-imm
|
||||
{ dst V int-regs 41 }
|
||||
{ obj V int-regs 1 }
|
||||
{ slot 2 }
|
||||
{ tag 7 }
|
||||
}
|
||||
T{ ##slot-imm
|
||||
{ dst V int-regs 44 }
|
||||
{ obj V int-regs 41 }
|
||||
{ slot 1 }
|
||||
{ tag 6 }
|
||||
}
|
||||
T{ ##compare-branch
|
||||
{ src1 V int-regs 25 }
|
||||
{ src2 V int-regs 44 }
|
||||
{ cc cc> }
|
||||
}
|
||||
}
|
||||
2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##add-imm
|
||||
{ dst V int-regs 54 }
|
||||
{ src1 V int-regs 25 }
|
||||
{ src2 8 }
|
||||
}
|
||||
T{ ##load-immediate { dst V int-regs 55 } { val 24 } }
|
||||
T{ ##inc-d { n 4 } }
|
||||
T{ ##inc-r { n 1 } }
|
||||
T{ ##replace { src V int-regs 25 } { loc D 2 } }
|
||||
T{ ##replace { src V int-regs 1 } { loc D 3 } }
|
||||
T{ ##replace { src V int-regs 5 } { loc D 4 } }
|
||||
T{ ##replace { src V int-regs 1 } { loc D 1 } }
|
||||
T{ ##replace { src V int-regs 54 } { loc D 0 } }
|
||||
T{ ##replace { src V int-regs 12 } { loc R 0 } }
|
||||
T{ ##fixnum-mul
|
||||
{ src1 V int-regs 54 }
|
||||
{ src2 V int-regs 55 }
|
||||
{ temp1 V int-regs 58 }
|
||||
{ temp2 V int-regs 59 }
|
||||
}
|
||||
T{ ##peek f V int-regs 1 D 0 }
|
||||
T{ ##peek f V int-regs 2 D 0 }
|
||||
T{ ##replace f V int-regs 1 D 0 }
|
||||
T{ ##replace f V int-regs 2 D 0 }
|
||||
T{ ##branch }
|
||||
}
|
||||
3 test-bb
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek { dst V int-regs 60 } { loc D 1 } }
|
||||
T{ ##slot-imm
|
||||
{ dst V int-regs 66 }
|
||||
{ obj V int-regs 60 }
|
||||
{ slot 2 }
|
||||
{ tag 7 }
|
||||
}
|
||||
T{ ##inc-d { n 1 } }
|
||||
T{ ##inc-r { n 1 } }
|
||||
T{ ##replace { src V int-regs 66 } { loc D 0 } }
|
||||
T{ ##replace { src V int-regs 60 } { loc R 0 } }
|
||||
T{ ##call { word resize-string } }
|
||||
T{ ##branch }
|
||||
}
|
||||
4 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek { dst V int-regs 67 } { loc R 0 } }
|
||||
T{ ##peek { dst V int-regs 68 } { loc D 0 } }
|
||||
T{ ##set-slot-imm
|
||||
{ src V int-regs 68 }
|
||||
{ obj V int-regs 67 }
|
||||
{ slot 2 }
|
||||
{ tag 7 }
|
||||
}
|
||||
T{ ##write-barrier
|
||||
{ src V int-regs 67 }
|
||||
{ card# V int-regs 75 }
|
||||
{ table V int-regs 76 }
|
||||
}
|
||||
T{ ##inc-d { n -1 } }
|
||||
T{ ##inc-r { n -1 } }
|
||||
T{ ##peek { dst V int-regs 94 } { loc D 0 } }
|
||||
T{ ##peek { dst V int-regs 96 } { loc D 1 } }
|
||||
T{ ##peek { dst V int-regs 98 } { loc D 2 } }
|
||||
T{ ##peek { dst V int-regs 100 } { loc D 3 } }
|
||||
T{ ##peek { dst V int-regs 102 } { loc D 4 } }
|
||||
T{ ##peek { dst V int-regs 106 } { loc R 0 } }
|
||||
T{ ##copy { dst V int-regs 95 } { src V int-regs 94 } }
|
||||
T{ ##copy { dst V int-regs 97 } { src V int-regs 96 } }
|
||||
T{ ##copy { dst V int-regs 99 } { src V int-regs 98 } }
|
||||
T{ ##copy { dst V int-regs 101 } { src V int-regs 100 } }
|
||||
T{ ##copy { dst V int-regs 103 } { src V int-regs 102 } }
|
||||
T{ ##copy { dst V int-regs 107 } { src V int-regs 106 } }
|
||||
T{ ##branch }
|
||||
}
|
||||
5 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d { n 3 } }
|
||||
T{ ##inc-r { n 1 } }
|
||||
T{ ##copy { dst V int-regs 95 } { src V int-regs 1 } }
|
||||
T{ ##copy { dst V int-regs 97 } { src V int-regs 25 } }
|
||||
T{ ##copy { dst V int-regs 99 } { src V int-regs 1 } }
|
||||
T{ ##copy { dst V int-regs 101 } { src V int-regs 5 } }
|
||||
T{ ##copy { dst V int-regs 103 } { src V int-regs 7 } }
|
||||
T{ ##copy { dst V int-regs 107 } { src V int-regs 12 } }
|
||||
T{ ##branch }
|
||||
}
|
||||
6 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-immediate
|
||||
{ dst V int-regs 78 }
|
||||
{ val 4611686018427387896 }
|
||||
}
|
||||
T{ ##and
|
||||
{ dst V int-regs 81 }
|
||||
{ src1 V int-regs 97 }
|
||||
{ src2 V int-regs 78 }
|
||||
}
|
||||
T{ ##set-slot-imm
|
||||
{ src V int-regs 81 }
|
||||
{ obj V int-regs 95 }
|
||||
{ slot 3 }
|
||||
{ tag 7 }
|
||||
}
|
||||
T{ ##inc-d { n -2 } }
|
||||
T{ ##copy { dst V int-regs 110 } { src V int-regs 99 } }
|
||||
T{ ##copy { dst V int-regs 111 } { src V int-regs 101 } }
|
||||
T{ ##copy { dst V int-regs 112 } { src V int-regs 103 } }
|
||||
T{ ##copy { dst V int-regs 117 } { src V int-regs 107 } }
|
||||
T{ ##branch }
|
||||
}
|
||||
7 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d { n 1 } }
|
||||
T{ ##inc-r { n 1 } }
|
||||
T{ ##copy { dst V int-regs 110 } { src V int-regs 1 } }
|
||||
T{ ##copy { dst V int-regs 111 } { src V int-regs 5 } }
|
||||
T{ ##copy { dst V int-regs 112 } { src V int-regs 7 } }
|
||||
T{ ##copy { dst V int-regs 117 } { src V int-regs 12 } }
|
||||
T{ ##branch }
|
||||
}
|
||||
8 test-bb
|
||||
|
||||
V{
|
||||
T{ ##inc-d { n 1 } }
|
||||
T{ ##inc-r { n -1 } }
|
||||
T{ ##replace { src V int-regs 117 } { loc D 0 } }
|
||||
T{ ##replace { src V int-regs 110 } { loc D 1 } }
|
||||
T{ ##replace { src V int-regs 111 } { loc D 2 } }
|
||||
T{ ##replace { src V int-regs 112 } { loc D 3 } }
|
||||
T{ ##epilogue }
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##return }
|
||||
}
|
||||
9 test-bb
|
||||
} 4 test-bb
|
||||
|
||||
test-diamond
|
||||
|
||||
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
|
||||
|
||||
[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
|
||||
|
||||
[ 1 ] [ 3 get predecessors>> first instructions>> [ _spill? ] count ] unit-test
|
||||
|
||||
[ 1 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
|
||||
|
||||
! Another test case for fencepost error in assignment pass
|
||||
V{ T{ ##branch } } 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##compare-imm-branch f V int-regs 0 5 cc= }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 0 }
|
||||
T{ ##peek f V int-regs 2 D 0 }
|
||||
T{ ##replace f V int-regs 1 D 0 }
|
||||
T{ ##replace f V int-regs 2 D 0 }
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##return }
|
||||
} 4 test-bb
|
||||
|
||||
test-diamond
|
||||
|
||||
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
|
||||
|
||||
[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
|
||||
|
||||
[ 1 ] [ 2 get instructions>> [ _reload? ] count ] unit-test
|
||||
|
||||
[ 0 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
|
||||
|
||||
[ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
|
||||
|
||||
! GC check tests
|
||||
|
||||
! Spill slot liveness was computed incorrectly, leading to a FEP
|
||||
! early in bootstrap on x86-32
|
||||
[ t ] [
|
||||
[
|
||||
H{ } clone live-ins set
|
||||
H{ } clone live-outs set
|
||||
H{ } clone phi-live-ins set
|
||||
T{ basic-block
|
||||
{ id 12345 }
|
||||
{ instructions
|
||||
V{
|
||||
T{ ##gc f V int-regs 6 V int-regs 7 }
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##peek f V int-regs 2 D 2 }
|
||||
T{ ##peek f V int-regs 3 D 3 }
|
||||
T{ ##peek f V int-regs 4 D 4 }
|
||||
T{ ##peek f V int-regs 5 D 5 }
|
||||
T{ ##replace f V int-regs 0 D 1 }
|
||||
T{ ##replace f V int-regs 1 D 2 }
|
||||
T{ ##replace f V int-regs 2 D 3 }
|
||||
T{ ##replace f V int-regs 3 D 4 }
|
||||
T{ ##replace f V int-regs 4 D 5 }
|
||||
T{ ##replace f V int-regs 5 D 0 }
|
||||
}
|
||||
}
|
||||
} dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
|
||||
instructions>> first
|
||||
live-values>> assoc-empty?
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##replace f V int-regs 1 D 1 }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##gc f V int-regs 2 V int-regs 3 }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##return }
|
||||
} 2 test-bb
|
||||
|
||||
0 get 1 get 1vector >>successors drop
|
||||
1 get 2 get 8 get V{ } 2sequence >>successors drop
|
||||
2 get 3 get 6 get V{ } 2sequence >>successors drop
|
||||
3 get 4 get 1vector >>successors drop
|
||||
4 get 5 get 1vector >>successors drop
|
||||
5 get 7 get 1vector >>successors drop
|
||||
6 get 7 get 1vector >>successors drop
|
||||
7 get 9 get 1vector >>successors drop
|
||||
8 get 9 get 1vector >>successors drop
|
||||
1 get 2 get 1vector >>successors drop
|
||||
|
||||
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
|
||||
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test
|
||||
|
||||
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##compare-imm-branch f V int-regs 1 5 cc= }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##gc f V int-regs 2 V int-regs 3 }
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##return }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##return }
|
||||
} 2 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
|
||||
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test
|
||||
|
|
|
@ -40,4 +40,5 @@ IN: compiler.cfg.linear-scan
|
|||
init-mapping
|
||||
dup reverse-post-order machine-registers (linear-scan)
|
||||
spill-counts get >>spill-counts
|
||||
cfg-changed
|
||||
] with-scope ;
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces kernel assocs accessors sequences math math.order fry
|
||||
combinators compiler.cfg.instructions compiler.cfg.registers
|
||||
combinators binary-search compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
|
||||
IN: compiler.cfg.linear-scan.live-intervals
|
||||
|
||||
|
@ -16,16 +16,21 @@ split-before split-after split-next
|
|||
start end ranges uses
|
||||
copy-from ;
|
||||
|
||||
: covers? ( insn# live-interval -- ? )
|
||||
ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
|
||||
GENERIC: covers? ( insn# obj -- ? )
|
||||
|
||||
: child-interval-at ( insn# interval -- interval' )
|
||||
dup split-after>> [
|
||||
2dup split-after>> start>> <
|
||||
[ split-before>> ] [ split-after>> ] if
|
||||
child-interval-at
|
||||
] [ nip ] if ;
|
||||
M: f covers? 2drop f ;
|
||||
|
||||
M: live-range covers? [ from>> ] [ to>> ] bi between? ;
|
||||
|
||||
M: live-interval covers? ( insn# live-interval -- ? )
|
||||
ranges>>
|
||||
dup length 4 <= [
|
||||
[ covers? ] with any?
|
||||
] [
|
||||
[ drop ] [ [ from>> <=> ] with search nip ] 2bi
|
||||
covers?
|
||||
] if ;
|
||||
|
||||
ERROR: dead-value-error vreg ;
|
||||
|
||||
: shorten-range ( n live-interval -- )
|
||||
|
@ -122,10 +127,10 @@ M: ##copy-float compute-live-intervals*
|
|||
dup ranges>> [ first from>> ] [ last to>> ] bi
|
||||
[ >>start ] [ >>end ] bi* drop ;
|
||||
|
||||
: check-start/end ( live-interval -- )
|
||||
[ [ start>> ] [ uses>> first ] bi assert= ]
|
||||
[ [ end>> ] [ uses>> last ] bi assert= ]
|
||||
bi ;
|
||||
ERROR: bad-live-interval live-interval ;
|
||||
|
||||
: check-start ( live-interval -- )
|
||||
dup start>> -1 = [ bad-live-interval ] [ drop ] if ;
|
||||
|
||||
: finish-live-intervals ( live-intervals -- )
|
||||
! Since live intervals are computed in a backward order, we have
|
||||
|
@ -135,7 +140,7 @@ M: ##copy-float compute-live-intervals*
|
|||
[ ranges>> reverse-here ]
|
||||
[ uses>> reverse-here ]
|
||||
[ compute-start/end ]
|
||||
[ check-start/end ]
|
||||
[ check-start ]
|
||||
} cleave
|
||||
] each ;
|
||||
|
||||
|
|
|
@ -1,7 +0,0 @@
|
|||
USING: arrays compiler.cfg.linear-scan.resolve kernel
|
||||
tools.test ;
|
||||
IN: compiler.cfg.linear-scan.resolve.tests
|
||||
|
||||
[ { 1 2 3 4 5 6 } ] [
|
||||
{ 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
|
||||
] unit-test
|
|
@ -3,6 +3,7 @@
|
|||
USING: accessors arrays assocs combinators
|
||||
combinators.short-circuit fry kernel locals
|
||||
make math sequences
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.linear-scan.assignment
|
||||
compiler.cfg.linear-scan.mapping compiler.cfg.liveness ;
|
||||
|
@ -30,42 +31,14 @@ IN: compiler.cfg.linear-scan.resolve
|
|||
[ resolve-value-data-flow ] with with each
|
||||
] { } make ;
|
||||
|
||||
: fork? ( from to -- ? )
|
||||
{
|
||||
[ drop successors>> length 1 >= ]
|
||||
[ nip predecessors>> length 1 = ]
|
||||
} 2&& ; inline
|
||||
|
||||
: insert-position/fork ( from to -- before after )
|
||||
nip instructions>> [ >array ] [ dup delete-all ] bi swap ;
|
||||
|
||||
: join? ( from to -- ? )
|
||||
{
|
||||
[ drop successors>> length 1 = ]
|
||||
[ nip predecessors>> length 1 >= ]
|
||||
} 2&& ; inline
|
||||
|
||||
: insert-position/join ( from to -- before after )
|
||||
drop instructions>> dup pop 1array ;
|
||||
|
||||
: insert-position ( bb to -- before after )
|
||||
{
|
||||
{ [ 2dup fork? ] [ insert-position/fork ] }
|
||||
{ [ 2dup join? ] [ insert-position/join ] }
|
||||
} cond ;
|
||||
|
||||
: 3append-here ( seq2 seq1 seq3 -- )
|
||||
#! Mutate seq1
|
||||
swap '[ _ push-all ] bi@ ;
|
||||
|
||||
: perform-mappings ( mappings bb to -- )
|
||||
pick empty? [ 3drop ] [
|
||||
[ mapping-instructions ] 2dip
|
||||
insert-position 3append-here
|
||||
: perform-mappings ( bb to mappings -- )
|
||||
dup empty? [ 3drop ] [
|
||||
mapping-instructions <simple-block>
|
||||
insert-basic-block
|
||||
] if ;
|
||||
|
||||
: resolve-edge-data-flow ( bb to -- )
|
||||
[ compute-mappings ] [ perform-mappings ] 2bi ;
|
||||
2dup compute-mappings perform-mappings ;
|
||||
|
||||
: resolve-block-data-flow ( bb -- )
|
||||
dup successors>> [ resolve-edge-data-flow ] with each ;
|
||||
|
|
|
@ -5,6 +5,7 @@ combinators assocs arrays locals cpu.architecture
|
|||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.stack-frame
|
||||
compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.linearization
|
||||
|
@ -30,8 +31,10 @@ M: insn linearize-insn , drop ;
|
|||
M: ##branch linearize-insn
|
||||
drop dup successors>> first emit-branch ;
|
||||
|
||||
: successors ( bb -- first second ) successors>> first2 ; inline
|
||||
|
||||
: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
|
||||
[ dup successors>> first2 ]
|
||||
[ dup successors ]
|
||||
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
|
||||
|
||||
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
|
||||
|
@ -51,6 +54,19 @@ M: ##compare-imm-branch linearize-insn
|
|||
M: ##compare-float-branch linearize-insn
|
||||
[ binary-conditional _compare-float-branch ] with-regs emit-branch ;
|
||||
|
||||
: overflow-conditional ( basic-block insn -- basic-block successor label2 dst src1 src2 )
|
||||
[ dup successors number>> ]
|
||||
[ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
|
||||
|
||||
M: ##fixnum-add linearize-insn
|
||||
[ overflow-conditional _fixnum-add ] with-regs emit-branch ;
|
||||
|
||||
M: ##fixnum-sub linearize-insn
|
||||
[ overflow-conditional _fixnum-sub ] with-regs emit-branch ;
|
||||
|
||||
M: ##fixnum-mul linearize-insn
|
||||
[ overflow-conditional _fixnum-mul ] with-regs emit-branch ;
|
||||
|
||||
M: ##dispatch linearize-insn
|
||||
swap
|
||||
[ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
|
||||
|
|
|
@ -43,9 +43,6 @@ SYMBOL: work-list
|
|||
[ nip kill-set ]
|
||||
2bi assoc-diff ;
|
||||
|
||||
: conjoin-at ( value key assoc -- )
|
||||
[ dupd ?set-at ] change-at ;
|
||||
|
||||
: compute-phi-live-in ( basic-block -- phi-live-in )
|
||||
instructions>> [ ##phi? ] filter [ f ] [
|
||||
H{ } clone [
|
||||
|
|
|
@ -1,10 +1,14 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors kernel assocs compiler.cfg.liveness compiler.cfg.rpo ;
|
||||
USING: locals accessors kernel assocs namespaces
|
||||
compiler.cfg compiler.cfg.liveness compiler.cfg.rpo ;
|
||||
IN: compiler.cfg.local
|
||||
|
||||
: optimize-basic-block ( bb init-quot insn-quot -- )
|
||||
[ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
|
||||
:: optimize-basic-block ( bb init-quot insn-quot -- )
|
||||
bb basic-block set
|
||||
bb live-in keys init-quot call
|
||||
bb insn-quot change-instructions drop ; inline
|
||||
|
||||
: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
|
||||
[ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; inline
|
||||
:: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
|
||||
cfg [ init-quot insn-quot optimize-basic-block ] each-basic-block
|
||||
cfg ; inline
|
|
@ -1,8 +1,8 @@
|
|||
USING: accessors arrays compiler.cfg.checker
|
||||
compiler.cfg.debugger compiler.cfg.def-use
|
||||
compiler.cfg.instructions fry kernel kernel.private math
|
||||
math.private sbufs sequences sequences.private sets
|
||||
slots.private strings tools.test vectors layouts ;
|
||||
math.partial-dispatch math.private sbufs sequences sequences.private sets
|
||||
slots.private strings strings.private tools.test vectors layouts ;
|
||||
IN: compiler.cfg.optimizer.tests
|
||||
|
||||
! Miscellaneous tests
|
||||
|
@ -31,6 +31,19 @@ IN: compiler.cfg.optimizer.tests
|
|||
[ [ 2 fixnum+ ] when 3 ]
|
||||
[ [ 2 fixnum- ] when 3 ]
|
||||
[ 10000 [ ] times ]
|
||||
[
|
||||
over integer? [
|
||||
over dup 16 <-integer-fixnum
|
||||
[ 0 >=-integer-fixnum ] [ drop f ] if [
|
||||
nip dup
|
||||
[ ] [ ] if
|
||||
] [ 2drop f ] if
|
||||
] [ 2drop f ] if
|
||||
]
|
||||
[
|
||||
pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
|
||||
set-string-nth-fast
|
||||
]
|
||||
} [
|
||||
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
|
||||
] each
|
||||
|
|
|
@ -6,10 +6,10 @@ compiler.cfg.predecessors
|
|||
compiler.cfg.useless-conditionals
|
||||
compiler.cfg.stack-analysis
|
||||
compiler.cfg.branch-splitting
|
||||
compiler.cfg.block-joining
|
||||
compiler.cfg.alias-analysis
|
||||
compiler.cfg.value-numbering
|
||||
compiler.cfg.dce
|
||||
compiler.cfg.branch-folding
|
||||
compiler.cfg.write-barrier
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.rpo
|
||||
|
@ -29,15 +29,15 @@ SYMBOL: check-optimizer?
|
|||
! The passes that need this document it.
|
||||
[
|
||||
optimize-tail-calls
|
||||
compute-predecessors
|
||||
delete-useless-conditionals
|
||||
compute-predecessors
|
||||
split-branches
|
||||
join-blocks
|
||||
compute-predecessors
|
||||
stack-analysis
|
||||
compute-liveness
|
||||
alias-analysis
|
||||
value-numbering
|
||||
fold-branches
|
||||
compute-predecessors
|
||||
eliminate-dead-code
|
||||
eliminate-write-barriers
|
||||
|
|
|
@ -1 +1,2 @@
|
|||
Slava Pestov
|
||||
Slava Pestov
|
||||
Daniel Ehrenberg
|
||||
|
|
|
@ -1,7 +1,10 @@
|
|||
IN: compiler.cfg.phi-elimination.tests
|
||||
! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.cfg.instructions compiler.cfg compiler.cfg.registers
|
||||
compiler.cfg.debugger compiler.cfg.phi-elimination kernel accessors
|
||||
sequences classes namespaces tools.test cpu.architecture arrays ;
|
||||
compiler.cfg.comparisons compiler.cfg.debugger locals
|
||||
compiler.cfg.phi-elimination kernel accessors sequences classes
|
||||
namespaces tools.test cpu.architecture arrays ;
|
||||
IN: compiler.cfg.phi-elimination.tests
|
||||
|
||||
V{ T{ ##branch } } 0 test-bb
|
||||
|
||||
|
@ -33,8 +36,20 @@ V{
|
|||
|
||||
test-diamond
|
||||
|
||||
3 vreg-counter set-global
|
||||
|
||||
[ ] [ cfg new 0 get >>entry eliminate-phis drop ] unit-test
|
||||
|
||||
[ T{ ##copy f V int-regs 3 V int-regs 1 } ] [ 2 get instructions>> second ] unit-test
|
||||
[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
|
||||
[ 2 ] [ 4 get instructions>> length ] unit-test
|
||||
[ T{ ##copy f V int-regs 4 V int-regs 1 } ] [
|
||||
2 get successors>> first instructions>> first
|
||||
] unit-test
|
||||
|
||||
[ T{ ##copy f V int-regs 4 V int-regs 2 } ] [
|
||||
3 get successors>> first instructions>> first
|
||||
] unit-test
|
||||
|
||||
[ T{ ##copy f V int-regs 3 V int-regs 4 } ] [
|
||||
4 get instructions>> first
|
||||
] unit-test
|
||||
|
||||
[ 3 ] [ 4 get instructions>> length ] unit-test
|
||||
|
|
|
@ -1,17 +1,26 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs fry kernel sequences
|
||||
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
|
||||
USING: accessors assocs fry kernel sequences namespaces
|
||||
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
|
||||
compiler.cfg.utilities compiler.cfg.hats make
|
||||
locals ;
|
||||
IN: compiler.cfg.phi-elimination
|
||||
|
||||
: insert-copy ( predecessor input output -- )
|
||||
'[ _ _ swap ##copy ] add-instructions ;
|
||||
|
||||
: eliminate-phi ( ##phi -- )
|
||||
[ inputs>> ] [ dst>> ] bi '[ _ insert-copy ] assoc-each ;
|
||||
: eliminate-phi ( ##phi -- ##copy )
|
||||
i
|
||||
[ [ inputs>> ] dip '[ _ insert-copy ] assoc-each ]
|
||||
[ [ dst>> ] dip \ ##copy new-insn ]
|
||||
2bi ;
|
||||
|
||||
: eliminate-phi-step ( bb -- )
|
||||
instructions>> [ dup ##phi? [ eliminate-phi f ] [ drop t ] if ] filter-here ;
|
||||
H{ } clone added-instructions set
|
||||
[ instructions>> [ dup ##phi? [ eliminate-phi ] when ] change-each ]
|
||||
[ insert-basic-blocks ]
|
||||
bi ;
|
||||
|
||||
: eliminate-phis ( cfg -- cfg' )
|
||||
dup [ eliminate-phi-step ] each-basic-block ;
|
||||
dup [ eliminate-phi-step ] each-basic-block
|
||||
cfg-changed ;
|
||||
|
|
|
@ -1,11 +1,17 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors namespaces kernel arrays parser ;
|
||||
USING: accessors namespaces kernel arrays parser math math.order ;
|
||||
IN: compiler.cfg.registers
|
||||
|
||||
! Virtual registers, used by CFG and machine IRs
|
||||
TUPLE: vreg { reg-class read-only } { n read-only } ;
|
||||
TUPLE: vreg { reg-class read-only } { n fixnum read-only } ;
|
||||
|
||||
M: vreg equal? over vreg? [ [ n>> ] bi@ eq? ] [ 2drop f ] if ;
|
||||
|
||||
M: vreg hashcode* nip n>> ;
|
||||
|
||||
SYMBOL: vreg-counter
|
||||
|
||||
: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
|
||||
|
||||
! Stack locations -- 'n' is an index starting from the top of the stack
|
||||
|
|
|
@ -0,0 +1,155 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel namespaces sequences
|
||||
compiler.cfg.instructions compiler.cfg.registers ;
|
||||
IN: compiler.cfg.renaming
|
||||
|
||||
SYMBOL: renamings
|
||||
|
||||
: rename-value ( vreg -- vreg' ) renamings get at ;
|
||||
|
||||
GENERIC: rename-insn-defs ( insn -- )
|
||||
|
||||
M: ##flushable rename-insn-defs
|
||||
[ rename-value ] change-dst
|
||||
drop ;
|
||||
|
||||
M: ##fixnum-overflow rename-insn-defs
|
||||
[ rename-value ] change-dst
|
||||
drop ;
|
||||
|
||||
M: _fixnum-overflow rename-insn-defs
|
||||
[ rename-value ] change-dst
|
||||
drop ;
|
||||
|
||||
M: insn rename-insn-defs drop ;
|
||||
|
||||
GENERIC: rename-insn-uses ( insn -- )
|
||||
|
||||
M: ##effect rename-insn-uses
|
||||
[ rename-value ] change-src
|
||||
drop ;
|
||||
|
||||
M: ##unary rename-insn-uses
|
||||
[ rename-value ] change-src
|
||||
drop ;
|
||||
|
||||
M: ##binary rename-insn-uses
|
||||
[ rename-value ] change-src1
|
||||
[ rename-value ] change-src2
|
||||
drop ;
|
||||
|
||||
M: ##binary-imm rename-insn-uses
|
||||
[ rename-value ] change-src1
|
||||
drop ;
|
||||
|
||||
M: ##slot rename-insn-uses
|
||||
[ rename-value ] change-obj
|
||||
[ rename-value ] change-slot
|
||||
drop ;
|
||||
|
||||
M: ##slot-imm rename-insn-uses
|
||||
[ rename-value ] change-obj
|
||||
drop ;
|
||||
|
||||
M: ##set-slot rename-insn-uses
|
||||
dup call-next-method
|
||||
[ rename-value ] change-obj
|
||||
[ rename-value ] change-slot
|
||||
drop ;
|
||||
|
||||
M: ##string-nth rename-insn-uses
|
||||
[ rename-value ] change-obj
|
||||
[ rename-value ] change-index
|
||||
drop ;
|
||||
|
||||
M: ##set-string-nth-fast rename-insn-uses
|
||||
dup call-next-method
|
||||
[ rename-value ] change-obj
|
||||
[ rename-value ] change-index
|
||||
drop ;
|
||||
|
||||
M: ##set-slot-imm rename-insn-uses
|
||||
dup call-next-method
|
||||
[ rename-value ] change-obj
|
||||
drop ;
|
||||
|
||||
M: ##alien-getter rename-insn-uses
|
||||
dup call-next-method
|
||||
[ rename-value ] change-src
|
||||
drop ;
|
||||
|
||||
M: ##alien-setter rename-insn-uses
|
||||
dup call-next-method
|
||||
[ rename-value ] change-value
|
||||
drop ;
|
||||
|
||||
M: ##conditional-branch rename-insn-uses
|
||||
[ rename-value ] change-src1
|
||||
[ rename-value ] change-src2
|
||||
drop ;
|
||||
|
||||
M: ##compare-imm-branch rename-insn-uses
|
||||
[ rename-value ] change-src1
|
||||
drop ;
|
||||
|
||||
M: ##dispatch rename-insn-uses
|
||||
[ rename-value ] change-src
|
||||
drop ;
|
||||
|
||||
M: ##fixnum-overflow rename-insn-uses
|
||||
[ rename-value ] change-src1
|
||||
[ rename-value ] change-src2
|
||||
drop ;
|
||||
|
||||
M: insn rename-insn-uses drop ;
|
||||
|
||||
: fresh-vreg ( vreg -- vreg' )
|
||||
reg-class>> next-vreg ;
|
||||
|
||||
GENERIC: fresh-insn-temps ( insn -- )
|
||||
|
||||
M: ##write-barrier fresh-insn-temps
|
||||
[ fresh-vreg ] change-card#
|
||||
[ fresh-vreg ] change-table
|
||||
drop ;
|
||||
|
||||
M: ##unary/temp fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##allot fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##dispatch fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##slot fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##set-slot fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##string-nth fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##set-string-nth-fast fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##compare fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##compare-imm fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##compare-float fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: ##gc fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp1
|
||||
[ fresh-vreg ] change-temp2
|
||||
drop ;
|
||||
|
||||
M: _dispatch fresh-insn-temps
|
||||
[ fresh-vreg ] change-temp drop ;
|
||||
|
||||
M: insn fresh-insn-temps drop ;
|
|
@ -0,0 +1,79 @@
|
|||
USING: accessors compiler.cfg compiler.cfg.debugger
|
||||
compiler.cfg.dominance compiler.cfg.instructions
|
||||
compiler.cfg.predecessors compiler.cfg.ssa assocs
|
||||
compiler.cfg.registers cpu.architecture kernel namespaces sequences
|
||||
tools.test vectors ;
|
||||
IN: compiler.cfg.ssa.tests
|
||||
|
||||
! Reset counters so that results are deterministic w.r.t. hash order
|
||||
0 vreg-counter set-global
|
||||
0 basic-block set-global
|
||||
|
||||
V{
|
||||
T{ ##load-immediate f V int-regs 1 100 }
|
||||
T{ ##add-imm f V int-regs 2 V int-regs 1 50 }
|
||||
T{ ##add-imm f V int-regs 2 V int-regs 2 10 }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-immediate f V int-regs 3 3 }
|
||||
T{ ##branch }
|
||||
} 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##load-immediate f V int-regs 3 4 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 3 D 0 }
|
||||
T{ ##return }
|
||||
} 3 test-bb
|
||||
|
||||
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||
1 get 3 get 1vector >>successors drop
|
||||
2 get 3 get 1vector >>successors drop
|
||||
|
||||
: test-ssa ( -- )
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
compute-dominance
|
||||
construct-ssa
|
||||
drop ;
|
||||
|
||||
[ ] [ test-ssa ] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##load-immediate f V int-regs 1 100 }
|
||||
T{ ##add-imm f V int-regs 2 V int-regs 1 50 }
|
||||
T{ ##add-imm f V int-regs 3 V int-regs 2 10 }
|
||||
T{ ##branch }
|
||||
}
|
||||
] [ 0 get instructions>> ] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##load-immediate f V int-regs 4 3 }
|
||||
T{ ##branch }
|
||||
}
|
||||
] [ 1 get instructions>> ] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##load-immediate f V int-regs 5 4 }
|
||||
T{ ##branch }
|
||||
}
|
||||
] [ 2 get instructions>> ] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##phi f V int-regs 6 H{ { 1 V int-regs 4 } { 2 V int-regs 5 } } }
|
||||
T{ ##replace f V int-regs 6 D 0 }
|
||||
T{ ##return }
|
||||
}
|
||||
] [
|
||||
3 get instructions>>
|
||||
[ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map
|
||||
] unit-test
|
|
@ -0,0 +1,146 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces kernel accessors sequences fry dlists
|
||||
deques assocs sets math combinators sorting
|
||||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.renaming
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.dominance
|
||||
compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.ssa
|
||||
|
||||
! SSA construction. Predecessors and dominance must be computed first.
|
||||
|
||||
! This is the classical algorithm based on dominance frontiers:
|
||||
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.25.8240
|
||||
|
||||
! Eventually might be worth trying something fancier:
|
||||
! http://portal.acm.org/citation.cfm?id=1065887.1065890
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Maps vreg to sequence of basic blocks
|
||||
SYMBOL: defs
|
||||
|
||||
! Maps basic blocks to sequences of vregs
|
||||
SYMBOL: inserting-phi-nodes
|
||||
|
||||
: compute-defs ( cfg -- )
|
||||
H{ } clone dup defs set
|
||||
'[
|
||||
dup instructions>> [
|
||||
defs-vregs [
|
||||
_ push-at
|
||||
] with each
|
||||
] with each
|
||||
] each-basic-block ;
|
||||
|
||||
SYMBOLS: has-already ever-on-work-list work-list ;
|
||||
|
||||
: init-insert-phi-nodes ( bbs -- )
|
||||
H{ } clone has-already set
|
||||
[ unique ever-on-work-list set ]
|
||||
[ <hashed-dlist> [ push-all-front ] keep work-list set ] bi ;
|
||||
|
||||
: add-to-work-list ( bb -- )
|
||||
dup ever-on-work-list get key? [ drop ] [
|
||||
[ ever-on-work-list get conjoin ]
|
||||
[ work-list get push-front ]
|
||||
bi
|
||||
] if ;
|
||||
|
||||
: insert-phi-node-later ( vreg bb -- )
|
||||
[ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
|
||||
inserting-phi-nodes get push-at ;
|
||||
|
||||
: compute-phi-node-in ( vreg bb -- )
|
||||
dup has-already get key? [ 2drop ] [
|
||||
[ insert-phi-node-later ]
|
||||
[ has-already get conjoin ]
|
||||
[ add-to-work-list ]
|
||||
tri
|
||||
] if ;
|
||||
|
||||
: compute-phi-nodes-for ( vreg bbs -- )
|
||||
dup length 2 >= [
|
||||
init-insert-phi-nodes
|
||||
work-list get [
|
||||
dom-frontier [
|
||||
compute-phi-node-in
|
||||
] with each
|
||||
] with slurp-deque
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: compute-phi-nodes ( -- )
|
||||
H{ } clone inserting-phi-nodes set
|
||||
defs get [ compute-phi-nodes-for ] assoc-each ;
|
||||
|
||||
: insert-phi-nodes-in ( phis bb -- )
|
||||
[ append ] change-instructions drop ;
|
||||
|
||||
: insert-phi-nodes ( -- )
|
||||
inserting-phi-nodes get [ swap insert-phi-nodes-in ] assoc-each ;
|
||||
|
||||
SYMBOLS: stacks originals ;
|
||||
|
||||
: init-renaming ( -- )
|
||||
H{ } clone stacks set
|
||||
H{ } clone originals set ;
|
||||
|
||||
: gen-name ( vreg -- vreg' )
|
||||
[ reg-class>> next-vreg ] keep
|
||||
[ stacks get push-at ]
|
||||
[ swap originals get set-at ]
|
||||
[ drop ]
|
||||
2tri ;
|
||||
|
||||
: top-name ( vreg -- vreg' )
|
||||
stacks get at last ;
|
||||
|
||||
GENERIC: rename-insn ( insn -- )
|
||||
|
||||
M: insn rename-insn
|
||||
[ dup uses-vregs [ dup top-name ] { } map>assoc renamings set rename-insn-uses ]
|
||||
[ dup defs-vregs [ dup gen-name ] { } map>assoc renamings set rename-insn-defs ]
|
||||
bi ;
|
||||
|
||||
M: ##phi rename-insn
|
||||
dup defs-vregs [ dup gen-name ] { } map>assoc renamings set rename-insn-defs ;
|
||||
|
||||
: rename-insns ( bb -- )
|
||||
instructions>> [ rename-insn ] each ;
|
||||
|
||||
: rename-successor-phi ( phi bb -- )
|
||||
swap inputs>> [ top-name ] change-at ;
|
||||
|
||||
: rename-successor-phis ( succ bb -- )
|
||||
[ inserting-phi-nodes get at ] dip
|
||||
'[ _ rename-successor-phi ] each ;
|
||||
|
||||
: rename-successors-phis ( bb -- )
|
||||
[ successors>> ] keep '[ _ rename-successor-phis ] each ;
|
||||
|
||||
: pop-stacks ( bb -- )
|
||||
instructions>> [
|
||||
defs-vregs originals get stacks get
|
||||
'[ _ at _ at pop* ] each
|
||||
] each ;
|
||||
|
||||
: rename-in-block ( bb -- )
|
||||
{
|
||||
[ rename-insns ]
|
||||
[ rename-successors-phis ]
|
||||
[ dom-children [ rename-in-block ] each ]
|
||||
[ pop-stacks ]
|
||||
} cleave ;
|
||||
|
||||
: rename ( cfg -- )
|
||||
init-renaming
|
||||
entry>> rename-in-block ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: construct-ssa ( cfg -- cfg' )
|
||||
dup [ compute-defs compute-phi-nodes insert-phi-nodes ] [ rename ] bi ;
|
|
@ -1,8 +1,8 @@
|
|||
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
|
||||
compiler.cfg.instructions compiler.cfg.stack-analysis.state
|
||||
compiler.cfg.utilities compiler.cfg compiler.cfg.registers
|
||||
compiler.cfg.debugger cpu.architecture make assocs namespaces
|
||||
sequences kernel classes ;
|
||||
|
||||
[
|
||||
|
@ -11,13 +11,15 @@ sequences kernel classes ;
|
|||
] [
|
||||
<state>
|
||||
|
||||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 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>> values
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
merge-locs locs>vregs>> keys added-phis get values first
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
@ -26,15 +28,16 @@ sequences kernel classes ;
|
|||
] [
|
||||
<state>
|
||||
|
||||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
|
||||
|
||||
[
|
||||
<state>
|
||||
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 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
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
[ merge-locs locs>vregs>> keys ] { } make drop
|
||||
1 get added-instructions get at first class
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
@ -42,15 +45,17 @@ sequences kernel classes ;
|
|||
] [
|
||||
<state>
|
||||
|
||||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
|
||||
|
||||
[
|
||||
<state> -1 >>ds-height
|
||||
<state> 2array
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
|
||||
[ merge-ds-heights ds-height>> ] { } make drop
|
||||
] keep first instructions>> first class
|
||||
<state> -1 >>ds-height
|
||||
<state> 2array
|
||||
|
||||
[ merge-ds-heights ds-height>> ] { } make drop
|
||||
1 get added-instructions get at first class
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
@ -63,6 +68,9 @@ sequences kernel classes ;
|
|||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
|
||||
[
|
||||
<state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
|
||||
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
|
||||
|
@ -82,6 +90,9 @@ sequences kernel classes ;
|
|||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
|
||||
[
|
||||
<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
|
||||
|
|
|
@ -1,12 +1,11 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs sequences accessors fry combinators grouping
|
||||
sets locals compiler.cfg compiler.cfg.hats compiler.cfg.instructions
|
||||
compiler.cfg.stack-analysis.state ;
|
||||
USING: kernel assocs sequences accessors fry combinators grouping sets
|
||||
arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats
|
||||
compiler.cfg.instructions compiler.cfg.stack-analysis.state
|
||||
compiler.cfg.registers compiler.cfg.utilities cpu.architecture ;
|
||||
IN: compiler.cfg.stack-analysis.merge
|
||||
|
||||
! XXX critical edges
|
||||
|
||||
: initial-state ( bb states -- state ) 2drop <state> ;
|
||||
|
||||
: single-predecessor ( bb states -- state ) nip first clone ;
|
||||
|
@ -27,14 +26,14 @@ IN: compiler.cfg.stack-analysis.merge
|
|||
[ nip first >>rs-height ]
|
||||
[ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
|
||||
|
||||
: assoc-map-values ( assoc quot -- assoc' )
|
||||
: assoc-map-keys ( assoc quot -- assoc' )
|
||||
'[ _ dip ] assoc-map ; inline
|
||||
|
||||
: translate-locs ( assoc state -- assoc' )
|
||||
'[ _ translate-loc ] assoc-map-values ;
|
||||
'[ _ translate-loc ] assoc-map-keys ;
|
||||
|
||||
: untranslate-locs ( assoc state -- assoc' )
|
||||
'[ _ untranslate-loc ] assoc-map-values ;
|
||||
'[ _ untranslate-loc ] assoc-map-keys ;
|
||||
|
||||
: collect-locs ( loc-maps states -- assoc )
|
||||
! assoc maps locs to sequences
|
||||
|
@ -45,12 +44,16 @@ IN: compiler.cfg.stack-analysis.merge
|
|||
: insert-peek ( predecessor loc state -- vreg )
|
||||
'[ _ _ translate-loc ^^peek ] add-instructions ;
|
||||
|
||||
SYMBOL: added-phis
|
||||
|
||||
: add-phi-later ( inputs -- vreg )
|
||||
[ int-regs next-vreg dup ] dip 2array added-phis get push ;
|
||||
|
||||
: merge-loc ( predecessors vregs loc state -- vreg )
|
||||
! Insert a ##phi in the current block where the input
|
||||
! is the vreg storing loc from each predecessor block
|
||||
[ dup ] 3dip
|
||||
'[ [ ] [ _ _ insert-peek ] ?if ] 2map
|
||||
dup all-equal? [ nip first ] [ zip ^^phi ] if ;
|
||||
dup all-equal? [ first ] [ add-phi-later ] if ;
|
||||
|
||||
:: merge-locs ( state predecessors states -- state )
|
||||
states [ locs>vregs>> ] map states collect-locs
|
||||
|
@ -77,30 +80,36 @@ IN: compiler.cfg.stack-analysis.merge
|
|||
over translate-locs
|
||||
>>changed-locs ;
|
||||
|
||||
ERROR: cannot-merge-poisoned states ;
|
||||
:: insert-phis ( bb -- )
|
||||
bb predecessors>> :> predecessors
|
||||
[
|
||||
added-phis get [| dst inputs |
|
||||
dst predecessors inputs zip ##phi
|
||||
] assoc-each
|
||||
] V{ } make bb instructions>> over push-all
|
||||
bb (>>instructions) ;
|
||||
|
||||
: multiple-predecessors ( bb states -- state )
|
||||
dup [ not ] any? [
|
||||
2drop <state>
|
||||
:: multiple-predecessors ( bb states -- state )
|
||||
states [ not ] any? [
|
||||
<state>
|
||||
bb add-to-work-list
|
||||
] [
|
||||
dup [ poisoned?>> ] any? [
|
||||
cannot-merge-poisoned
|
||||
] [
|
||||
[ state new ] 2dip
|
||||
[ predecessors>> ] dip
|
||||
{
|
||||
[ merge-ds-heights ]
|
||||
[ merge-rs-heights ]
|
||||
[ merge-locs ]
|
||||
[ nip merge-actual-locs ]
|
||||
[ nip merge-changed-locs ]
|
||||
} 2cleave
|
||||
] if
|
||||
[
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
bb predecessors>> :> predecessors
|
||||
state new
|
||||
predecessors states merge-ds-heights
|
||||
predecessors states merge-rs-heights
|
||||
predecessors states merge-locs
|
||||
states merge-actual-locs
|
||||
states merge-changed-locs
|
||||
bb insert-basic-blocks
|
||||
bb insert-phis
|
||||
] with-scope
|
||||
] if ;
|
||||
|
||||
: merge-states ( bb states -- state )
|
||||
! If any states are poisoned, save all registers
|
||||
! to the stack in each branch
|
||||
dup length {
|
||||
{ 0 [ initial-state ] }
|
||||
{ 1 [ single-predecessor ] }
|
||||
|
|
|
@ -91,15 +91,15 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
! Sync before a back-edge, not after
|
||||
! ##peeks should be inserted before a ##loop-entry
|
||||
! Don't optimize out the constants
|
||||
[ 1 t ] [
|
||||
[ t ] [
|
||||
[ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
|
||||
[ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
|
||||
[ ##load-immediate? ] any?
|
||||
] unit-test
|
||||
|
||||
! Correct height tracking
|
||||
[ t ] [
|
||||
[ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
|
||||
reverse-post-order 3 swap nth
|
||||
reverse-post-order 4 swap nth
|
||||
instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
|
||||
2array { D 1 D 0 } set=
|
||||
] unit-test
|
||||
|
@ -126,7 +126,7 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
stack-analysis
|
||||
drop
|
||||
|
||||
3 get instructions>> second loc>>
|
||||
3 get successors>> first instructions>> first loc>>
|
||||
] unit-test
|
||||
|
||||
! Do inserted ##peeks reference the correct stack location if
|
||||
|
@ -156,7 +156,7 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
stack-analysis
|
||||
drop
|
||||
|
||||
3 get instructions>> [ ##peek? ] find nip loc>>
|
||||
3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
|
||||
] unit-test
|
||||
|
||||
! Missing ##replace
|
||||
|
@ -170,9 +170,9 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
! Inserted ##peeks reference the wrong stack location
|
||||
[ t ] [
|
||||
[ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
|
||||
eliminate-dead-code reverse-post-order 3 swap nth
|
||||
eliminate-dead-code reverse-post-order 4 swap nth
|
||||
instructions>> [ ##peek? ] filter [ loc>> ] map
|
||||
{ R 0 D 0 D 1 } set=
|
||||
{ D 0 D 1 } set=
|
||||
] unit-test
|
||||
|
||||
[ D 0 ] [
|
||||
|
@ -200,5 +200,5 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
stack-analysis
|
||||
drop
|
||||
|
||||
3 get instructions>> [ ##peek? ] find nip loc>>
|
||||
3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
|
||||
] unit-test
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel namespaces math sequences fry grouping
|
||||
sets make combinators
|
||||
sets make combinators dlists deques
|
||||
compiler.cfg
|
||||
compiler.cfg.copy-prop
|
||||
compiler.cfg.def-use
|
||||
|
@ -10,9 +10,12 @@ compiler.cfg.registers
|
|||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.stack-analysis.state
|
||||
compiler.cfg.stack-analysis.merge ;
|
||||
compiler.cfg.stack-analysis.merge
|
||||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.stack-analysis
|
||||
|
||||
SYMBOL: global-optimization?
|
||||
|
||||
: redundant-replace? ( vreg loc -- ? )
|
||||
dup state get untranslate-loc n>> 0 <
|
||||
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
|
||||
|
@ -58,17 +61,16 @@ UNION: sync-if-back-edge
|
|||
##conditional-branch
|
||||
##compare-imm-branch
|
||||
##dispatch
|
||||
##loop-entry ;
|
||||
|
||||
: back-edge? ( from to -- ? )
|
||||
[ number>> ] bi@ > ;
|
||||
##loop-entry
|
||||
##fixnum-overflow ;
|
||||
|
||||
: sync-state? ( -- ? )
|
||||
basic-block get successors>>
|
||||
[ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;
|
||||
|
||||
M: sync-if-back-edge visit
|
||||
sync-state? [ sync-state ] when , ;
|
||||
global-optimization? get [ sync-state? [ sync-state ] when ] unless
|
||||
, ;
|
||||
|
||||
: eliminate-peek ( dst src -- )
|
||||
! the requested stack location is already in 'src'
|
||||
|
@ -85,42 +87,16 @@ M: ##replace visit
|
|||
M: ##copy visit
|
||||
[ call-next-method ] [ record-copy ] bi ;
|
||||
|
||||
! Instructions that poison the stack state
|
||||
UNION: poison-insn
|
||||
##jump
|
||||
##return
|
||||
##callback-return
|
||||
##fixnum-mul-tail
|
||||
##fixnum-add-tail
|
||||
##fixnum-sub-tail ;
|
||||
|
||||
M: poison-insn visit call-next-method poison-state ;
|
||||
|
||||
! Instructions that kill all live vregs
|
||||
UNION: kill-vreg-insn
|
||||
poison-insn
|
||||
##stack-frame
|
||||
##call
|
||||
##prologue
|
||||
##epilogue
|
||||
##fixnum-mul
|
||||
##fixnum-add
|
||||
##fixnum-sub
|
||||
##alien-invoke
|
||||
##alien-indirect
|
||||
##alien-callback ;
|
||||
|
||||
M: kill-vreg-insn visit sync-state , ;
|
||||
|
||||
! Maps basic-blocks to states
|
||||
SYMBOLS: state-in state-out ;
|
||||
SYMBOL: state-out
|
||||
|
||||
: block-in-state ( bb -- states )
|
||||
dup predecessors>> state-out get '[ _ at ] map merge-states ;
|
||||
|
||||
: set-block-in-state ( state bb -- )
|
||||
[ clone ] dip state-in get set-at ;
|
||||
|
||||
: set-block-out-state ( state bb -- )
|
||||
[ clone ] dip state-out get set-at ;
|
||||
|
||||
|
@ -130,20 +106,20 @@ SYMBOLS: state-in state-out ;
|
|||
[
|
||||
dup basic-block set
|
||||
dup block-in-state
|
||||
[ swap set-block-in-state ] [
|
||||
state [
|
||||
[ instructions>> [ visit ] each ]
|
||||
[ [ state get ] dip set-block-out-state ]
|
||||
[ ]
|
||||
tri
|
||||
] with-variable
|
||||
] 2bi
|
||||
state [
|
||||
[ instructions>> [ visit ] each ]
|
||||
[ [ state get ] dip set-block-out-state ]
|
||||
[ ]
|
||||
tri
|
||||
] with-variable
|
||||
] V{ } make >>instructions drop ;
|
||||
|
||||
: stack-analysis ( cfg -- cfg' )
|
||||
[
|
||||
<hashed-dlist> work-list set
|
||||
H{ } clone copies set
|
||||
H{ } clone state-in set
|
||||
H{ } clone state-out set
|
||||
dup [ visit-block ] each-basic-block
|
||||
global-optimization? get [ work-list get [ visit-block ] slurp-deque ] when
|
||||
cfg-changed
|
||||
] with-scope ;
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! 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 deques
|
||||
compiler.cfg.registers ;
|
||||
IN: compiler.cfg.stack-analysis.state
|
||||
|
||||
|
@ -47,3 +47,7 @@ M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - <rs-loc> ;
|
|||
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> ;
|
||||
|
||||
SYMBOL: work-list
|
||||
|
||||
: add-to-work-list ( bb -- ) work-list get push-front ;
|
||||
|
|
|
@ -2,10 +2,12 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit kernel math
|
||||
namespaces sequences fry combinators
|
||||
compiler.utilities
|
||||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.instructions ;
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.tco
|
||||
|
||||
! Tail call optimization. You must run compute-predecessors after this
|
||||
|
@ -18,8 +20,6 @@ IN: compiler.cfg.tco
|
|||
[ second ##return? ]
|
||||
} 1&& ;
|
||||
|
||||
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
|
||||
|
||||
: tail-call? ( bb -- ? )
|
||||
{
|
||||
[ instructions>> { [ length 2 >= ] [ last ##branch? ] } 1&& ]
|
||||
|
@ -53,28 +53,11 @@ IN: compiler.cfg.tco
|
|||
[ [ cfg get entry>> successors>> first ] dip successors>> push ]
|
||||
tri ;
|
||||
|
||||
: fixnum-tail-call? ( bb -- ? )
|
||||
instructions>> penultimate
|
||||
{ [ ##fixnum-add? ] [ ##fixnum-sub? ] [ ##fixnum-mul? ] } 1|| ;
|
||||
|
||||
GENERIC: convert-fixnum-tail-call* ( src1 src2 insn -- insn' )
|
||||
|
||||
M: ##fixnum-add convert-fixnum-tail-call* drop \ ##fixnum-add-tail new-insn ;
|
||||
M: ##fixnum-sub convert-fixnum-tail-call* drop \ ##fixnum-sub-tail new-insn ;
|
||||
M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn ;
|
||||
|
||||
: convert-fixnum-tail-call ( bb -- )
|
||||
[
|
||||
[ src1>> ] [ src2>> ] [ ] tri
|
||||
convert-fixnum-tail-call*
|
||||
] convert-tail-call ;
|
||||
|
||||
: optimize-tail-call ( bb -- )
|
||||
dup tail-call? [
|
||||
{
|
||||
{ [ dup loop-tail-call? ] [ convert-loop-tail-call ] }
|
||||
{ [ dup word-tail-call? ] [ convert-word-tail-call ] }
|
||||
{ [ dup fixnum-tail-call? ] [ convert-fixnum-tail-call ] }
|
||||
[ drop ]
|
||||
} cond
|
||||
] [ drop ] if ;
|
||||
|
@ -82,4 +65,4 @@ M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn
|
|||
: optimize-tail-calls ( cfg -- cfg' )
|
||||
dup cfg set
|
||||
dup [ optimize-tail-call ] each-basic-block
|
||||
f >>post-order ;
|
||||
cfg-changed ;
|
|
@ -11,10 +11,6 @@ IN: compiler.cfg.two-operand
|
|||
! since x86 has LEA and IMUL instructions which are effectively
|
||||
! three-operand addition and multiplication, respectively.
|
||||
|
||||
: make-copy ( dst src -- insn ) \ ##copy new-insn ; inline
|
||||
|
||||
: make-copy/float ( dst src -- insn ) \ ##copy-float new-insn ; inline
|
||||
|
||||
: convert-two-operand/integer ( insn -- )
|
||||
[ [ dst>> ] [ src1>> ] bi ##copy ]
|
||||
[ dup dst>> >>src1 , ]
|
||||
|
@ -40,10 +36,15 @@ M: ##or convert-two-operand* convert-two-operand/integer ;
|
|||
M: ##or-imm convert-two-operand* convert-two-operand/integer ;
|
||||
M: ##xor convert-two-operand* convert-two-operand/integer ;
|
||||
M: ##xor-imm convert-two-operand* convert-two-operand/integer ;
|
||||
M: ##shl convert-two-operand* convert-two-operand/integer ;
|
||||
M: ##shl-imm convert-two-operand* convert-two-operand/integer ;
|
||||
M: ##shr convert-two-operand* convert-two-operand/integer ;
|
||||
M: ##shr-imm convert-two-operand* convert-two-operand/integer ;
|
||||
M: ##sar convert-two-operand* convert-two-operand/integer ;
|
||||
M: ##sar-imm convert-two-operand* convert-two-operand/integer ;
|
||||
|
||||
M: ##fixnum-overflow convert-two-operand* convert-two-operand/integer ;
|
||||
|
||||
M: ##add-float convert-two-operand* convert-two-operand/float ;
|
||||
M: ##sub-float convert-two-operand* convert-two-operand/float ;
|
||||
M: ##mul-float convert-two-operand* convert-two-operand/float ;
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences math combinators combinators.short-circuit
|
||||
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
|
||||
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
|
||||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.useless-conditionals
|
||||
|
||||
: delete-conditional? ( bb -- ? )
|
||||
|
@ -18,4 +19,4 @@ IN: compiler.cfg.useless-conditionals
|
|||
dup [
|
||||
dup delete-conditional? [ delete-conditional ] [ drop ] if
|
||||
] each-basic-block
|
||||
f >>post-order ;
|
||||
cfg-changed ;
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math layouts make sequences combinators
|
||||
cpu.architecture namespaces compiler.cfg
|
||||
compiler.cfg.instructions ;
|
||||
USING: accessors assocs combinators combinators.short-circuit
|
||||
compiler.cfg compiler.cfg.instructions cpu.architecture kernel
|
||||
layouts locals make math namespaces sequences sets vectors fry ;
|
||||
IN: compiler.cfg.utilities
|
||||
|
||||
: value-info-small-fixnum? ( value-info -- ? )
|
||||
|
@ -33,7 +33,65 @@ IN: compiler.cfg.utilities
|
|||
building off
|
||||
basic-block off ;
|
||||
|
||||
: stop-iterating ( -- next ) end-basic-block f ;
|
||||
|
||||
: emit-primitive ( node -- )
|
||||
word>> ##call ##branch begin-basic-block ;
|
||||
|
||||
: with-branch ( quot -- final-bb )
|
||||
[
|
||||
begin-basic-block
|
||||
call
|
||||
basic-block get dup [ ##branch ] when
|
||||
] with-scope ; inline
|
||||
|
||||
: emit-conditional ( branches -- )
|
||||
end-basic-block
|
||||
begin-basic-block
|
||||
basic-block get '[ [ _ swap successors>> push ] when* ] each ;
|
||||
|
||||
: back-edge? ( from to -- ? )
|
||||
[ number>> ] bi@ >= ;
|
||||
|
||||
: empty-block? ( bb -- ? )
|
||||
instructions>> {
|
||||
[ length 1 = ]
|
||||
[ first ##branch? ]
|
||||
} 1&& ;
|
||||
|
||||
SYMBOL: visited
|
||||
|
||||
: (skip-empty-blocks) ( bb -- bb' )
|
||||
dup visited get key? [
|
||||
dup empty-block? [
|
||||
dup visited get conjoin
|
||||
successors>> first (skip-empty-blocks)
|
||||
] when
|
||||
] unless ;
|
||||
|
||||
: skip-empty-blocks ( bb -- bb' )
|
||||
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
|
||||
|
||||
! assoc mapping predecessors to sequences
|
||||
SYMBOL: added-instructions
|
||||
|
||||
: add-instructions ( predecessor quot -- )
|
||||
[
|
||||
added-instructions get
|
||||
[ drop V{ } clone ] cache
|
||||
building
|
||||
] dip with-variable ; inline
|
||||
|
||||
:: insert-basic-block ( from to bb -- )
|
||||
bb from 1vector >>predecessors drop
|
||||
bb to 1vector >>successors drop
|
||||
to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
|
||||
from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
|
||||
|
||||
: <simple-block> ( insns -- bb )
|
||||
<basic-block>
|
||||
swap >vector
|
||||
\ ##branch new-insn over push
|
||||
>>instructions ;
|
||||
|
||||
: insert-basic-blocks ( bb -- )
|
||||
[ added-instructions get ] dip
|
||||
'[ [ _ ] dip <simple-block> insert-basic-block ] assoc-each ;
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors classes kernel math namespaces combinators
|
||||
compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
|
||||
combinators.short-circuit compiler.cfg.instructions
|
||||
compiler.cfg.value-numbering.graph ;
|
||||
IN: compiler.cfg.value-numbering.expressions
|
||||
|
||||
! Referentially-transparent expressions
|
||||
|
@ -11,15 +12,29 @@ TUPLE: binary-expr < expr in1 in2 ;
|
|||
TUPLE: commutative-expr < binary-expr ;
|
||||
TUPLE: compare-expr < binary-expr cc ;
|
||||
TUPLE: constant-expr < expr value ;
|
||||
TUPLE: reference-expr < expr value ;
|
||||
|
||||
: <constant> ( constant -- expr )
|
||||
f swap constant-expr boa ; inline
|
||||
|
||||
M: constant-expr equal?
|
||||
over constant-expr? [
|
||||
[ [ value>> ] bi@ = ]
|
||||
[ [ value>> class ] bi@ = ] 2bi
|
||||
and
|
||||
{
|
||||
[ [ value>> class ] bi@ = ]
|
||||
[ [ value>> ] bi@ = ]
|
||||
} 2&&
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
: <reference> ( constant -- expr )
|
||||
f swap reference-expr boa ; inline
|
||||
|
||||
M: reference-expr equal?
|
||||
over reference-expr? [
|
||||
[ value>> ] bi@ {
|
||||
{ [ 2dup eq? ] [ 2drop t ] }
|
||||
{ [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
|
||||
[ 2drop f ]
|
||||
} cond
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
! Expressions whose values are inputs to the basic block. We
|
||||
|
@ -39,6 +54,8 @@ GENERIC: >expr ( insn -- expr )
|
|||
|
||||
M: ##load-immediate >expr val>> <constant> ;
|
||||
|
||||
M: ##load-reference >expr obj>> <reference> ;
|
||||
|
||||
M: ##unary >expr
|
||||
[ class ] [ src>> vreg>vn ] bi unary-expr boa ;
|
||||
|
||||
|
|
|
@ -1,69 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs sequences kernel accessors
|
||||
compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
|
||||
IN: compiler.cfg.value-numbering.propagate
|
||||
|
||||
! If two vregs compute the same value, replace references to
|
||||
! the latter with the former.
|
||||
|
||||
: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ; inline
|
||||
|
||||
GENERIC: propagate ( insn -- insn )
|
||||
|
||||
M: ##effect propagate
|
||||
[ resolve ] change-src ;
|
||||
|
||||
M: ##unary propagate
|
||||
[ resolve ] change-src ;
|
||||
|
||||
M: ##binary propagate
|
||||
[ resolve ] change-src1
|
||||
[ resolve ] change-src2 ;
|
||||
|
||||
M: ##binary-imm propagate
|
||||
[ resolve ] change-src1 ;
|
||||
|
||||
M: ##slot propagate
|
||||
[ resolve ] change-obj
|
||||
[ resolve ] change-slot ;
|
||||
|
||||
M: ##slot-imm propagate
|
||||
[ resolve ] change-obj ;
|
||||
|
||||
M: ##set-slot propagate
|
||||
call-next-method
|
||||
[ resolve ] change-obj
|
||||
[ resolve ] change-slot ;
|
||||
|
||||
M: ##string-nth propagate
|
||||
[ resolve ] change-obj
|
||||
[ resolve ] change-index ;
|
||||
|
||||
M: ##set-slot-imm propagate
|
||||
call-next-method
|
||||
[ resolve ] change-obj ;
|
||||
|
||||
M: ##alien-getter propagate
|
||||
call-next-method
|
||||
[ resolve ] change-src ;
|
||||
|
||||
M: ##alien-setter propagate
|
||||
call-next-method
|
||||
[ resolve ] change-value ;
|
||||
|
||||
M: ##conditional-branch propagate
|
||||
[ resolve ] change-src1
|
||||
[ resolve ] change-src2 ;
|
||||
|
||||
M: ##compare-imm-branch propagate
|
||||
[ resolve ] change-src1 ;
|
||||
|
||||
M: ##dispatch propagate
|
||||
[ resolve ] change-src ;
|
||||
|
||||
M: ##fixnum-overflow propagate
|
||||
[ resolve ] change-src1
|
||||
[ resolve ] change-src2 ;
|
||||
|
||||
M: insn propagate ;
|
|
@ -1 +0,0 @@
|
|||
Propagation pass to update code after value numbering
|
|
@ -1,16 +1,32 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors locals combinators combinators.short-circuit arrays
|
||||
USING: accessors combinators combinators.short-circuit arrays
|
||||
fry kernel layouts math namespaces sequences cpu.architecture
|
||||
math.bitwise compiler.cfg.hats compiler.cfg.instructions
|
||||
math.bitwise math.order classes vectors
|
||||
compiler.cfg
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.value-numbering.expressions
|
||||
compiler.cfg.value-numbering.graph
|
||||
compiler.cfg.value-numbering.simplify ;
|
||||
IN: compiler.cfg.value-numbering.rewrite
|
||||
|
||||
GENERIC: rewrite ( insn -- insn' )
|
||||
: vreg-small-constant? ( vreg -- ? )
|
||||
vreg>expr {
|
||||
[ constant-expr? ]
|
||||
[ value>> small-enough? ]
|
||||
} 1&& ;
|
||||
|
||||
M: insn rewrite ;
|
||||
! Outputs f to mean no change
|
||||
|
||||
GENERIC: rewrite* ( insn -- insn/f )
|
||||
|
||||
: rewrite ( insn -- insn' )
|
||||
dup [ number-values ] [ rewrite* ] bi
|
||||
[ rewrite ] [ ] ?if ;
|
||||
|
||||
M: insn rewrite* drop f ;
|
||||
|
||||
: ##branch-t? ( insn -- ? )
|
||||
dup ##compare-imm-branch? [
|
||||
|
@ -49,13 +65,16 @@ M: insn rewrite ;
|
|||
[ src2>> tag-mask get bitand 0 = ]
|
||||
} 1&& ; inline
|
||||
|
||||
: tagged>constant ( n -- n' )
|
||||
tag-bits get neg shift ; inline
|
||||
|
||||
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
|
||||
[ src1>> vreg>expr in1>> vn>vreg ]
|
||||
[ src2>> tag-bits get neg shift ]
|
||||
[ src2>> tagged>constant ]
|
||||
[ cc>> ]
|
||||
tri ; inline
|
||||
|
||||
GENERIC: rewrite-tagged-comparison ( insn -- insn' )
|
||||
GENERIC: rewrite-tagged-comparison ( insn -- insn/f )
|
||||
|
||||
M: ##compare-imm-branch rewrite-tagged-comparison
|
||||
(rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
|
||||
|
@ -64,41 +83,6 @@ M: ##compare-imm rewrite-tagged-comparison
|
|||
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
|
||||
i \ ##compare-imm new-insn ;
|
||||
|
||||
M: ##compare-imm-branch rewrite
|
||||
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
|
||||
dup ##compare-imm-branch? [
|
||||
dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
|
||||
] when ;
|
||||
|
||||
:: >compare-imm ( insn swap? -- insn' )
|
||||
insn dst>>
|
||||
insn src1>>
|
||||
insn src2>> swap? [ swap ] when vreg>constant
|
||||
insn cc>> swap? [ swap-cc ] when
|
||||
i \ ##compare-imm new-insn ; inline
|
||||
|
||||
! M: ##compare rewrite
|
||||
! dup [ src1>> ] [ src2>> ] bi
|
||||
! [ vreg>expr constant-expr? ] bi@ 2array {
|
||||
! { { f t } [ f >compare-imm ] }
|
||||
! { { t f } [ t >compare-imm ] }
|
||||
! [ drop ]
|
||||
! } case ;
|
||||
|
||||
:: >compare-imm-branch ( insn swap? -- insn' )
|
||||
insn src1>>
|
||||
insn src2>> swap? [ swap ] when vreg>constant
|
||||
insn cc>> swap? [ swap-cc ] when
|
||||
\ ##compare-imm-branch new-insn ; inline
|
||||
|
||||
! M: ##compare-branch rewrite
|
||||
! dup [ src1>> ] [ src2>> ] bi
|
||||
! [ vreg>expr constant-expr? ] bi@ 2array {
|
||||
! { { f t } [ f >compare-imm-branch ] }
|
||||
! { { t f } [ t >compare-imm-branch ] }
|
||||
! [ drop ]
|
||||
! } case ;
|
||||
|
||||
: rewrite-redundant-comparison? ( insn -- ? )
|
||||
{
|
||||
[ src1>> vreg>expr compare-expr? ]
|
||||
|
@ -114,101 +98,259 @@ M: ##compare-imm-branch rewrite
|
|||
} case
|
||||
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
|
||||
|
||||
M: ##compare-imm rewrite
|
||||
dup rewrite-redundant-comparison? [
|
||||
rewrite-redundant-comparison
|
||||
dup number-values rewrite
|
||||
] when
|
||||
dup ##compare-imm? [
|
||||
dup rewrite-tagged-comparison? [
|
||||
rewrite-tagged-comparison
|
||||
dup number-values rewrite
|
||||
] when
|
||||
] when ;
|
||||
ERROR: bad-comparison ;
|
||||
|
||||
: constant-fold ( insn -- insn' )
|
||||
dup dst>> vreg>expr dup constant-expr? [
|
||||
[ dst>> ] [ value>> ] bi* \ ##load-immediate new-insn
|
||||
dup number-values
|
||||
] [
|
||||
drop
|
||||
: (fold-compare-imm) ( insn -- ? )
|
||||
[ [ src1>> vreg>constant ] [ src2>> ] bi ] [ cc>> ] bi
|
||||
pick integer?
|
||||
[ [ <=> ] dip evaluate-cc ]
|
||||
[
|
||||
2nip {
|
||||
{ cc= [ f ] }
|
||||
{ cc/= [ t ] }
|
||||
[ bad-comparison ]
|
||||
} case
|
||||
] if ;
|
||||
|
||||
: (new-imm-insn) ( insn dst src1 n op -- new-insn/insn )
|
||||
[ cell-bits bits ] dip over small-enough? [
|
||||
new-insn dup number-values nip
|
||||
] [
|
||||
2drop 2drop
|
||||
] if constant-fold ; inline
|
||||
: fold-compare-imm? ( insn -- ? )
|
||||
src1>> vreg>expr [ constant-expr? ] [ reference-expr? ] bi or ;
|
||||
|
||||
: new-imm-insn ( insn dst src n op -- n' op' )
|
||||
2dup [ sgn ] dip 2array
|
||||
: fold-branch ( ? -- insn )
|
||||
0 1 ?
|
||||
basic-block get [ nth 1vector ] change-successors drop
|
||||
\ ##branch new-insn ;
|
||||
|
||||
: fold-compare-imm-branch ( insn -- insn/f )
|
||||
(fold-compare-imm) fold-branch ;
|
||||
|
||||
M: ##compare-imm-branch rewrite*
|
||||
{
|
||||
{ { -1 ##add-imm } [ drop neg \ ##sub-imm (new-imm-insn) ] }
|
||||
{ { -1 ##sub-imm } [ drop neg \ ##add-imm (new-imm-insn) ] }
|
||||
[ drop (new-imm-insn) ]
|
||||
} case ; inline
|
||||
{ [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
|
||||
{ [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
|
||||
{ [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
: combine-imm? ( insn op -- ? )
|
||||
[ src1>> vreg>expr op>> ] dip = ;
|
||||
: swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
|
||||
[ [ swap ] dip swap-cc ] when ; inline
|
||||
|
||||
: (combine-imm) ( insn quot op -- insn )
|
||||
: >compare-imm-branch ( insn swap? -- insn' )
|
||||
[
|
||||
[ src1>> ]
|
||||
[ src2>> ]
|
||||
[ cc>> ]
|
||||
tri
|
||||
] dip
|
||||
swap-compare
|
||||
[ vreg>constant ] dip
|
||||
\ ##compare-imm-branch new-insn ; inline
|
||||
|
||||
: self-compare? ( insn -- ? )
|
||||
[ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
|
||||
|
||||
: (rewrite-self-compare) ( insn -- ? )
|
||||
cc>> { cc= cc<= cc>= } memq? ;
|
||||
|
||||
: rewrite-self-compare-branch ( insn -- insn' )
|
||||
(rewrite-self-compare) fold-branch ;
|
||||
|
||||
M: ##compare-branch rewrite*
|
||||
{
|
||||
{ [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] }
|
||||
{ [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] }
|
||||
{ [ dup self-compare? ] [ rewrite-self-compare-branch ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
: >compare-imm ( insn swap? -- insn' )
|
||||
[
|
||||
{
|
||||
[ dst>> ]
|
||||
[ src1>> ]
|
||||
[ src2>> ]
|
||||
[ cc>> ]
|
||||
} cleave
|
||||
] dip
|
||||
swap-compare
|
||||
[ vreg>constant ] dip
|
||||
i \ ##compare-imm new-insn ; inline
|
||||
|
||||
: >boolean-insn ( insn ? -- insn' )
|
||||
[ dst>> ] dip
|
||||
{
|
||||
{ t [ t \ ##load-reference new-insn ] }
|
||||
{ f [ \ f tag-number \ ##load-immediate new-insn ] }
|
||||
} case ;
|
||||
|
||||
: rewrite-self-compare ( insn -- insn' )
|
||||
dup (rewrite-self-compare) >boolean-insn ;
|
||||
|
||||
M: ##compare rewrite*
|
||||
{
|
||||
{ [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] }
|
||||
{ [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] }
|
||||
{ [ dup self-compare? ] [ rewrite-self-compare ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
: fold-compare-imm ( insn -- insn' )
|
||||
dup (fold-compare-imm) >boolean-insn ;
|
||||
|
||||
M: ##compare-imm rewrite*
|
||||
{
|
||||
{ [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
|
||||
{ [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
|
||||
{ [ dup fold-compare-imm? ] [ fold-compare-imm ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
: constant-fold? ( insn -- ? )
|
||||
src1>> vreg>expr constant-expr? ; inline
|
||||
|
||||
GENERIC: constant-fold* ( x y insn -- z )
|
||||
|
||||
M: ##add-imm constant-fold* drop + ;
|
||||
M: ##sub-imm constant-fold* drop - ;
|
||||
M: ##mul-imm constant-fold* drop * ;
|
||||
M: ##and-imm constant-fold* drop bitand ;
|
||||
M: ##or-imm constant-fold* drop bitor ;
|
||||
M: ##xor-imm constant-fold* drop bitxor ;
|
||||
M: ##shr-imm constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ;
|
||||
M: ##sar-imm constant-fold* drop neg shift ;
|
||||
M: ##shl-imm constant-fold* drop shift ;
|
||||
|
||||
: constant-fold ( insn -- insn' )
|
||||
[ dst>> ]
|
||||
[ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi
|
||||
\ ##load-immediate new-insn ; inline
|
||||
|
||||
: reassociate? ( insn -- ? )
|
||||
[ src1>> vreg>expr op>> ] [ class ] bi = ; inline
|
||||
|
||||
: reassociate ( insn op -- insn )
|
||||
[
|
||||
{
|
||||
[ ]
|
||||
[ dst>> ]
|
||||
[ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ]
|
||||
[ src2>> ]
|
||||
} cleave
|
||||
] [ call ] [ ] tri* new-imm-insn ; inline
|
||||
[ ]
|
||||
} cleave constant-fold*
|
||||
] dip
|
||||
over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline
|
||||
|
||||
:: combine-imm ( insn quot op -- insn )
|
||||
insn op combine-imm? [
|
||||
insn quot op (combine-imm)
|
||||
] [
|
||||
insn
|
||||
] if ; inline
|
||||
|
||||
M: ##add-imm rewrite
|
||||
M: ##add-imm rewrite*
|
||||
{
|
||||
{ [ dup \ ##add-imm combine-imm? ] [ [ + ] \ ##add-imm (combine-imm) ] }
|
||||
{ [ dup \ ##sub-imm combine-imm? ] [ [ - ] \ ##sub-imm (combine-imm) ] }
|
||||
[ ]
|
||||
{ [ dup constant-fold? ] [ constant-fold ] }
|
||||
{ [ dup reassociate? ] [ \ ##add-imm reassociate ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
M: ##sub-imm rewrite
|
||||
: sub-imm>add-imm ( insn -- insn' )
|
||||
[ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
|
||||
[ \ ##add-imm new-insn ] [ 3drop f ] if ;
|
||||
|
||||
M: ##sub-imm rewrite*
|
||||
{
|
||||
{ [ dup \ ##add-imm combine-imm? ] [ [ - ] \ ##add-imm (combine-imm) ] }
|
||||
{ [ dup \ ##sub-imm combine-imm? ] [ [ + ] \ ##sub-imm (combine-imm) ] }
|
||||
[ ]
|
||||
{ [ dup constant-fold? ] [ constant-fold ] }
|
||||
[ sub-imm>add-imm ]
|
||||
} cond ;
|
||||
|
||||
M: ##mul-imm rewrite
|
||||
dup src2>> dup power-of-2? [
|
||||
[ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
|
||||
dup number-values
|
||||
] [
|
||||
drop [ * ] \ ##mul-imm combine-imm
|
||||
] if ;
|
||||
: strength-reduce-mul ( insn -- insn' )
|
||||
[ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
|
||||
|
||||
M: ##and-imm rewrite [ bitand ] \ ##and-imm combine-imm ;
|
||||
: strength-reduce-mul? ( insn -- ? )
|
||||
src2>> power-of-2? ;
|
||||
|
||||
M: ##or-imm rewrite [ bitor ] \ ##or-imm combine-imm ;
|
||||
M: ##mul-imm rewrite*
|
||||
{
|
||||
{ [ dup constant-fold? ] [ constant-fold ] }
|
||||
{ [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
|
||||
{ [ dup reassociate? ] [ \ ##mul-imm reassociate ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
M: ##xor-imm rewrite [ bitxor ] \ ##xor-imm combine-imm ;
|
||||
M: ##and-imm rewrite*
|
||||
{
|
||||
{ [ dup constant-fold? ] [ constant-fold ] }
|
||||
{ [ dup reassociate? ] [ \ ##and-imm reassociate ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
: rewrite-add? ( insn -- ? )
|
||||
src2>> {
|
||||
[ vreg>expr constant-expr? ]
|
||||
[ vreg>constant small-enough? ]
|
||||
} 1&& ;
|
||||
M: ##or-imm rewrite*
|
||||
{
|
||||
{ [ dup constant-fold? ] [ constant-fold ] }
|
||||
{ [ dup reassociate? ] [ \ ##or-imm reassociate ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
M: ##add rewrite
|
||||
dup rewrite-add? [
|
||||
[ dst>> ]
|
||||
[ src1>> ]
|
||||
[ src2>> vreg>constant ] tri \ ##add-imm new-insn
|
||||
dup number-values
|
||||
] when ;
|
||||
M: ##xor-imm rewrite*
|
||||
{
|
||||
{ [ dup constant-fold? ] [ constant-fold ] }
|
||||
{ [ dup reassociate? ] [ \ ##xor-imm reassociate ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
M: ##sub rewrite constant-fold ;
|
||||
M: ##shl-imm rewrite*
|
||||
{
|
||||
{ [ dup constant-fold? ] [ constant-fold ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
M: ##shr-imm rewrite*
|
||||
{
|
||||
{ [ dup constant-fold? ] [ constant-fold ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
M: ##sar-imm rewrite*
|
||||
{
|
||||
{ [ dup constant-fold? ] [ constant-fold ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
: insn>imm-insn ( insn op swap? -- )
|
||||
swap [
|
||||
[ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
|
||||
[ swap ] when vreg>constant
|
||||
] dip new-insn ; inline
|
||||
|
||||
: rewrite-arithmetic ( insn op -- ? )
|
||||
{
|
||||
{ [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
|
||||
[ 2drop f ]
|
||||
} cond ; inline
|
||||
|
||||
: rewrite-arithmetic-commutative ( insn op -- ? )
|
||||
{
|
||||
{ [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
|
||||
{ [ over src1>> vreg-small-constant? ] [ t insn>imm-insn ] }
|
||||
[ 2drop f ]
|
||||
} cond ; inline
|
||||
|
||||
M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ;
|
||||
|
||||
: subtraction-identity? ( insn -- ? )
|
||||
[ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ;
|
||||
|
||||
: rewrite-subtraction-identity ( insn -- insn' )
|
||||
dst>> 0 \ ##load-immediate new-insn ;
|
||||
|
||||
M: ##sub rewrite*
|
||||
{
|
||||
{ [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
|
||||
[ \ ##sub-imm rewrite-arithmetic ]
|
||||
} cond ;
|
||||
|
||||
M: ##mul rewrite* \ ##mul-imm rewrite-arithmetic-commutative ;
|
||||
|
||||
M: ##and rewrite* \ ##and-imm rewrite-arithmetic-commutative ;
|
||||
|
||||
M: ##or rewrite* \ ##or-imm rewrite-arithmetic-commutative ;
|
||||
|
||||
M: ##xor rewrite* \ ##xor-imm rewrite-arithmetic-commutative ;
|
||||
|
||||
M: ##shl rewrite* \ ##shl-imm rewrite-arithmetic ;
|
||||
|
||||
M: ##shr rewrite* \ ##shr-imm rewrite-arithmetic ;
|
||||
|
||||
M: ##sar rewrite* \ ##sar-imm rewrite-arithmetic ;
|
||||
|
|
|
@ -32,6 +32,8 @@ M: unary-expr simplify*
|
|||
|
||||
: expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline
|
||||
|
||||
: expr-one? ( expr -- ? ) T{ constant-expr f f 1 } = ; inline
|
||||
|
||||
: >binary-expr< ( expr -- in1 in2 )
|
||||
[ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline
|
||||
|
||||
|
@ -44,18 +46,54 @@ M: unary-expr simplify*
|
|||
|
||||
: simplify-sub ( expr -- vn/expr/f )
|
||||
>binary-expr< {
|
||||
{ [ 2dup eq? ] [ 2drop T{ constant-expr f f 0 } ] }
|
||||
{ [ dup expr-zero? ] [ drop ] }
|
||||
[ 2drop f ]
|
||||
} cond ; inline
|
||||
|
||||
: useless-shift? ( in1 in2 -- ? )
|
||||
: simplify-mul ( expr -- vn/expr/f )
|
||||
>binary-expr< {
|
||||
{ [ over expr-one? ] [ drop ] }
|
||||
{ [ dup expr-one? ] [ drop ] }
|
||||
[ 2drop f ]
|
||||
} cond ; inline
|
||||
|
||||
: simplify-and ( expr -- vn/expr/f )
|
||||
>binary-expr< {
|
||||
{ [ 2dup eq? ] [ drop ] }
|
||||
[ 2drop f ]
|
||||
} cond ; inline
|
||||
|
||||
: simplify-or ( expr -- vn/expr/f )
|
||||
>binary-expr< {
|
||||
{ [ 2dup eq? ] [ drop ] }
|
||||
{ [ over expr-zero? ] [ nip ] }
|
||||
{ [ dup expr-zero? ] [ drop ] }
|
||||
[ 2drop f ]
|
||||
} cond ; inline
|
||||
|
||||
: simplify-xor ( expr -- vn/expr/f )
|
||||
>binary-expr< {
|
||||
{ [ over expr-zero? ] [ nip ] }
|
||||
{ [ dup expr-zero? ] [ drop ] }
|
||||
[ 2drop f ]
|
||||
} cond ; inline
|
||||
|
||||
: useless-shr? ( in1 in2 -- ? )
|
||||
over op>> \ ##shl-imm eq?
|
||||
[ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
|
||||
|
||||
: simplify-shift ( expr -- vn/expr/f )
|
||||
>binary-expr<
|
||||
2dup useless-shift? [ drop in1>> ] [ 2drop f ] if ; inline
|
||||
: simplify-shr ( expr -- vn/expr/f )
|
||||
>binary-expr< {
|
||||
{ [ 2dup useless-shr? ] [ drop in1>> ] }
|
||||
{ [ dup expr-zero? ] [ drop ] }
|
||||
[ 2drop f ]
|
||||
} cond ; inline
|
||||
|
||||
: simplify-shl ( expr -- vn/expr/f )
|
||||
>binary-expr< {
|
||||
{ [ dup expr-zero? ] [ drop ] }
|
||||
[ 2drop f ]
|
||||
} cond ; inline
|
||||
|
||||
M: binary-expr simplify*
|
||||
dup op>> {
|
||||
|
@ -63,8 +101,20 @@ M: binary-expr simplify*
|
|||
{ \ ##add-imm [ simplify-add ] }
|
||||
{ \ ##sub [ simplify-sub ] }
|
||||
{ \ ##sub-imm [ simplify-sub ] }
|
||||
{ \ ##shr-imm [ simplify-shift ] }
|
||||
{ \ ##sar-imm [ simplify-shift ] }
|
||||
{ \ ##mul [ simplify-mul ] }
|
||||
{ \ ##mul-imm [ simplify-mul ] }
|
||||
{ \ ##and [ simplify-and ] }
|
||||
{ \ ##and-imm [ simplify-and ] }
|
||||
{ \ ##or [ simplify-or ] }
|
||||
{ \ ##or-imm [ simplify-or ] }
|
||||
{ \ ##xor [ simplify-xor ] }
|
||||
{ \ ##xor-imm [ simplify-xor ] }
|
||||
{ \ ##shr [ simplify-shr ] }
|
||||
{ \ ##shr-imm [ simplify-shr ] }
|
||||
{ \ ##sar [ simplify-shr ] }
|
||||
{ \ ##sar-imm [ simplify-shr ] }
|
||||
{ \ ##shl [ simplify-shl ] }
|
||||
{ \ ##shl-imm [ simplify-shl ] }
|
||||
[ 2drop f ]
|
||||
} case ;
|
||||
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -1,16 +1,19 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs biassocs classes kernel math accessors
|
||||
sorting sets sequences
|
||||
sorting sets sequences fry
|
||||
compiler.cfg
|
||||
compiler.cfg.local
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.renaming
|
||||
compiler.cfg.value-numbering.graph
|
||||
compiler.cfg.value-numbering.expressions
|
||||
compiler.cfg.value-numbering.propagate
|
||||
compiler.cfg.value-numbering.simplify
|
||||
compiler.cfg.value-numbering.rewrite ;
|
||||
IN: compiler.cfg.value-numbering
|
||||
|
||||
! Local value numbering. Predecessors must be recomputed after this
|
||||
|
||||
: number-input-values ( live-in -- )
|
||||
[ [ f next-input-expr simplify ] dip set-vn ] each ;
|
||||
|
||||
|
@ -19,8 +22,18 @@ IN: compiler.cfg.value-numbering
|
|||
init-expressions
|
||||
number-input-values ;
|
||||
|
||||
: vreg>vreg-mapping ( -- assoc )
|
||||
vregs>vns get [ keys ] keep
|
||||
'[ dup _ [ at ] [ value-at ] bi ] H{ } map>assoc ;
|
||||
|
||||
: rename-uses ( insns -- )
|
||||
vreg>vreg-mapping renamings [
|
||||
[ rename-insn-uses ] each
|
||||
] with-variable ;
|
||||
|
||||
: value-numbering-step ( insns -- insns' )
|
||||
[ [ number-values ] [ rewrite propagate ] bi ] map ;
|
||||
[ rewrite ] map dup rename-uses ;
|
||||
|
||||
: value-numbering ( cfg -- cfg' )
|
||||
[ init-value-numbering ] [ value-numbering-step ] local-optimization ;
|
||||
[ init-value-numbering ] [ value-numbering-step ] local-optimization
|
||||
cfg-changed ;
|
||||
|
|
|
@ -165,24 +165,21 @@ M: ##or generate-insn dst/src1/src2 %or ;
|
|||
M: ##or-imm generate-insn dst/src1/src2 %or-imm ;
|
||||
M: ##xor generate-insn dst/src1/src2 %xor ;
|
||||
M: ##xor-imm generate-insn dst/src1/src2 %xor-imm ;
|
||||
M: ##shl generate-insn dst/src1/src2 %shl ;
|
||||
M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
|
||||
M: ##shr generate-insn dst/src1/src2 %shr ;
|
||||
M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
|
||||
M: ##sar generate-insn dst/src1/src2 %sar ;
|
||||
M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
|
||||
M: ##not generate-insn dst/src %not ;
|
||||
M: ##log2 generate-insn dst/src %log2 ;
|
||||
|
||||
: src1/src2 ( insn -- src1 src2 )
|
||||
[ src1>> register ] [ src2>> register ] bi ; inline
|
||||
: label/dst/src1/src2 ( insn -- label dst src1 src2 )
|
||||
[ label>> lookup-label ] [ dst/src1/src2 ] bi ; inline
|
||||
|
||||
: src1/src2/temp1/temp2 ( insn -- src1 src2 temp1 temp2 )
|
||||
[ src1/src2 ] [ temp1>> register ] [ temp2>> register ] tri ; inline
|
||||
|
||||
M: ##fixnum-add generate-insn src1/src2 %fixnum-add ;
|
||||
M: ##fixnum-add-tail generate-insn src1/src2 %fixnum-add-tail ;
|
||||
M: ##fixnum-sub generate-insn src1/src2 %fixnum-sub ;
|
||||
M: ##fixnum-sub-tail generate-insn src1/src2 %fixnum-sub-tail ;
|
||||
M: ##fixnum-mul generate-insn src1/src2/temp1/temp2 %fixnum-mul ;
|
||||
M: ##fixnum-mul-tail generate-insn src1/src2/temp1/temp2 %fixnum-mul-tail ;
|
||||
M: _fixnum-add generate-insn label/dst/src1/src2 %fixnum-add ;
|
||||
M: _fixnum-sub generate-insn label/dst/src1/src2 %fixnum-sub ;
|
||||
M: _fixnum-mul generate-insn label/dst/src1/src2 %fixnum-mul ;
|
||||
|
||||
: dst/src/temp ( insn -- dst src temp )
|
||||
[ dst/src ] [ temp>> register ] bi ; inline
|
||||
|
|
|
@ -314,4 +314,11 @@ M: cucumber equal? "The cucumber has no equal" throw ;
|
|||
|
||||
! Regression from Doug's value numbering changes
|
||||
[ t ] [ 2 [ 1 swap fixnum< ] compile-call ] unit-test
|
||||
[ 3 ] [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test
|
||||
[ 3 ] [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test
|
||||
|
||||
cell 4 = [
|
||||
[ 0 ] [ 101 [ dup fixnum-fast 1 fixnum+fast 20 fixnum-shift-fast 20 fixnum-shift-fast ] compile-call ] unit-test
|
||||
] when
|
||||
|
||||
! Regression from Slava's value numbering changes
|
||||
[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test
|
|
@ -213,12 +213,25 @@ IN: compiler.tests.intrinsics
|
|||
[ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test
|
||||
[ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test
|
||||
|
||||
[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
|
||||
[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
|
||||
[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
|
||||
[ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-call ] unit-test
|
||||
[ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-call ] unit-test
|
||||
[ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
|
||||
[ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-call ] unit-test
|
||||
[ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] unit-test
|
||||
[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
|
||||
|
||||
[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test
|
||||
[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
|
||||
[ 8 ] [ 1 3 [ fixnum-shift-fast ] compile-call ] unit-test
|
||||
[ 8 ] [ 1 3 [ 15 bitand fixnum-shift-fast ] compile-call ] unit-test
|
||||
[ 8 ] [ 1 [ 3 fixnum-shift-fast ] compile-call ] unit-test
|
||||
[ 8 ] [ [ 1 3 fixnum-shift-fast ] compile-call ] unit-test
|
||||
[ -8 ] [ -1 3 [ fixnum-shift-fast ] compile-call ] unit-test
|
||||
[ -8 ] [ -1 3 [ 15 bitand fixnum-shift-fast ] compile-call ] unit-test
|
||||
[ -8 ] [ -1 [ 3 fixnum-shift-fast ] compile-call ] unit-test
|
||||
[ -8 ] [ [ -1 3 fixnum-shift-fast ] compile-call ] unit-test
|
||||
|
||||
[ 2 ] [ 8 -2 [ fixnum-shift-fast ] compile-call ] unit-test
|
||||
[ 2 ] [ 8 2 [ 15 bitand neg fixnum-shift-fast ] compile-call ] unit-test
|
||||
[ 2 ] [ 8 [ -2 fixnum-shift-fast ] compile-call ] unit-test
|
||||
|
||||
[ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-call ] unit-test
|
||||
[ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-call ] unit-test
|
||||
|
@ -227,6 +240,13 @@ IN: compiler.tests.intrinsics
|
|||
[ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] unit-test
|
||||
[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
|
||||
|
||||
[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
|
||||
[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
|
||||
[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
|
||||
|
||||
[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test
|
||||
[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
|
||||
|
||||
[ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
|
||||
[ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
|
||||
[ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
|
||||
|
|
|
@ -242,6 +242,11 @@ M: float detect-float ;
|
|||
{ fixnum-shift-fast } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ 1 swap 7 bitand shift ]
|
||||
{ shift fixnum-shift } inlined?
|
||||
] unit-test
|
||||
|
||||
cell-bits 32 = [
|
||||
[ t ] [
|
||||
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs match fry accessors namespaces make effects
|
||||
sequences sequences.private quotations generic macros arrays
|
||||
|
@ -15,7 +15,9 @@ compiler.tree.def-use
|
|||
compiler.tree.builder
|
||||
compiler.tree.optimizer
|
||||
compiler.tree.combinators
|
||||
compiler.tree.checker ;
|
||||
compiler.tree.checker
|
||||
compiler.tree.dead-code
|
||||
compiler.tree.modular-arithmetic ;
|
||||
FROM: fry => _ ;
|
||||
RENAME: _ match => __
|
||||
IN: compiler.tree.debugger
|
||||
|
@ -201,8 +203,15 @@ SYMBOL: node-count
|
|||
|
||||
: cleaned-up-tree ( quot -- nodes )
|
||||
[
|
||||
check-optimizer? on
|
||||
build-tree optimize-tree
|
||||
build-tree
|
||||
analyze-recursive
|
||||
normalize
|
||||
propagate
|
||||
cleanup
|
||||
compute-def-use
|
||||
remove-dead-code
|
||||
compute-def-use
|
||||
optimize-modular-arithmetic
|
||||
] with-scope ;
|
||||
|
||||
: inlined? ( quot seq/word -- ? )
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences words memoize combinators
|
||||
classes classes.builtin classes.tuple math.partial-dispatch
|
||||
fry assocs
|
||||
fry assocs combinators.short-circuit
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
|
@ -29,10 +29,12 @@ GENERIC: finalize* ( node -- nodes )
|
|||
M: #copy finalize* drop f ;
|
||||
|
||||
M: #shuffle finalize*
|
||||
dup
|
||||
[ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
|
||||
[ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
|
||||
bi and [ drop f ] when ;
|
||||
dup {
|
||||
[ [ in-d>> length ] [ out-d>> length ] bi = ]
|
||||
[ [ in-r>> length ] [ out-r>> length ] bi = ]
|
||||
[ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at = ] 2all? ]
|
||||
[ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at = ] 2all? ]
|
||||
} 1&& [ drop f ] when ;
|
||||
|
||||
MEMO: cached-expansion ( word -- nodes )
|
||||
def>> splice-final ;
|
||||
|
@ -46,6 +48,9 @@ M: predicate finalize-word
|
|||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
M: math-partial finalize-word
|
||||
dup primitive? [ drop ] [ nip cached-expansion ] if ;
|
||||
|
||||
M: word finalize-word drop ;
|
||||
|
||||
M: #call finalize*
|
||||
|
|
|
@ -0,0 +1,2 @@
|
|||
Slava Pestov
|
||||
Daniel Ehrenberg
|
|
@ -1,12 +1,15 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: compiler.tree.modular-arithmetic.tests
|
||||
USING: kernel kernel.private tools.test math math.partial-dispatch
|
||||
math.private accessors slots.private sequences strings sbufs
|
||||
compiler.tree.builder
|
||||
compiler.tree.optimizer
|
||||
compiler.tree.debugger ;
|
||||
compiler.tree.normalization
|
||||
compiler.tree.debugger
|
||||
alien.accessors layouts combinators byte-arrays ;
|
||||
|
||||
: test-modular-arithmetic ( quot -- quot' )
|
||||
build-tree optimize-tree nodes>quot ;
|
||||
cleaned-up-tree nodes>quot ;
|
||||
|
||||
[ [ >R >fixnum R> >fixnum fixnum+fast ] ]
|
||||
[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test
|
||||
|
@ -135,4 +138,36 @@ TUPLE: declared-fixnum { x fixnum } ;
|
|||
] unit-test
|
||||
|
||||
[ [ >fixnum 255 fixnum-bitand ] ]
|
||||
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
|
||||
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
|
||||
|
||||
[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-1 ] ]
|
||||
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-1 ] test-modular-arithmetic ] unit-test
|
||||
|
||||
[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-2 ] ]
|
||||
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-2 ] test-modular-arithmetic ] unit-test
|
||||
|
||||
cell {
|
||||
{ 4 [ [ [ "COMPLEX SHUFFLE" fixnum+ "COMPLEX SHUFFLE" set-alien-unsigned-4 ] ] ] }
|
||||
{ 8 [ [ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-4 ] ] ] }
|
||||
} case
|
||||
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-4 ] test-modular-arithmetic ] unit-test
|
||||
|
||||
[ [ "COMPLEX SHUFFLE" fixnum+ "COMPLEX SHUFFLE" set-alien-unsigned-8 ] ]
|
||||
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-8 ] test-modular-arithmetic ] unit-test
|
||||
|
||||
[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-signed-1 ] ]
|
||||
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-1 ] test-modular-arithmetic ] unit-test
|
||||
|
||||
[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-signed-2 ] ]
|
||||
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-2 ] test-modular-arithmetic ] unit-test
|
||||
|
||||
cell {
|
||||
{ 4 [ [ [ "COMPLEX SHUFFLE" fixnum+ "COMPLEX SHUFFLE" set-alien-signed-4 ] ] ] }
|
||||
{ 8 [ [ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-signed-4 ] ] ] }
|
||||
} case
|
||||
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-4 ] test-modular-arithmetic ] unit-test
|
||||
|
||||
[ [ "COMPLEX SHUFFLE" fixnum+ "COMPLEX SHUFFLE" set-alien-signed-8 ] ]
|
||||
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-8 ] test-modular-arithmetic ] unit-test
|
||||
|
||||
[ t ] [ [ { fixnum byte-array } declare [ + ] with map ] { + fixnum+ >fixnum } inlined? ] unit-test
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math math.partial-dispatch namespaces sequences sets
|
||||
accessors assocs words kernel memoize fry combinators
|
||||
combinators.short-circuit
|
||||
combinators.short-circuit layouts alien.accessors
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.def-use
|
||||
|
@ -28,6 +28,16 @@ IN: compiler.tree.modular-arithmetic
|
|||
{ bitand bitor bitxor bitnot }
|
||||
[ t "modular-arithmetic" set-word-prop ] each
|
||||
|
||||
{
|
||||
>fixnum
|
||||
set-alien-unsigned-1 set-alien-signed-1
|
||||
set-alien-unsigned-2 set-alien-signed-2
|
||||
}
|
||||
cell 8 = [
|
||||
{ set-alien-unsigned-4 set-alien-signed-4 } append
|
||||
] when
|
||||
[ t "low-order" set-word-prop ] each
|
||||
|
||||
SYMBOL: modularize-values
|
||||
|
||||
: modular-value? ( value -- ? )
|
||||
|
@ -54,7 +64,7 @@ M: node maybe-modularize* 2drop ;
|
|||
GENERIC: compute-modularized-values* ( node -- )
|
||||
|
||||
M: #call compute-modularized-values*
|
||||
dup word>> \ >fixnum eq?
|
||||
dup word>> "low-order" word-prop
|
||||
[ in-d>> first maybe-modularize ] [ drop ] if ;
|
||||
|
||||
M: node compute-modularized-values* drop ;
|
||||
|
|
|
@ -0,0 +1,2 @@
|
|||
Slava Pestov
|
||||
Daniel Ehrenberg
|
|
@ -0,0 +1,51 @@
|
|||
! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.tree.propagation.call-effect tools.test fry math effects kernel
|
||||
compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences ;
|
||||
IN: compiler.tree.propagation.call-effect.tests
|
||||
|
||||
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
|
||||
[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
|
||||
[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
|
||||
[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
|
||||
|
||||
[ t ] [ [ + ] cached-effect (( a b -- c )) effect= ] unit-test
|
||||
[ t ] [ 5 [ + ] curry cached-effect (( a -- c )) effect= ] unit-test
|
||||
[ t ] [ 5 [ ] curry cached-effect (( -- c )) effect= ] unit-test
|
||||
[ t ] [ [ dup ] [ drop ] compose cached-effect (( a -- b )) effect= ] unit-test
|
||||
[ t ] [ [ drop ] [ dup ] compose cached-effect (( a b -- c d )) effect= ] unit-test
|
||||
[ t ] [ [ 2drop ] [ dup ] compose cached-effect (( a b c -- d e )) effect= ] unit-test
|
||||
[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect (( -- a )) effect= ] unit-test
|
||||
[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect (( a -- )) effect= ] unit-test
|
||||
|
||||
: optimized-quot ( quot -- quot' )
|
||||
build-tree optimize-tree nodes>quot ;
|
||||
|
||||
: compiled-call2 ( a quot: ( a -- b ) -- b )
|
||||
call( a -- b ) ;
|
||||
|
||||
: compiled-execute2 ( a b word: ( a b -- c ) -- c )
|
||||
execute( a b -- c ) ;
|
||||
|
||||
[ [ 3 ] ] [ [ 1 2 \ + execute( a b -- c ) ] optimized-quot ] unit-test
|
||||
[ [ 3 ] ] [ [ 1 2 [ + ] call( a b -- c ) ] optimized-quot ] unit-test
|
||||
[ [ 3 ] ] [ [ 1 2 '[ _ + ] call( a -- b ) ] optimized-quot ] unit-test
|
||||
[ [ 3 ] ] [ [ 1 2 '[ _ ] [ + ] compose call( a -- b ) ] optimized-quot ] unit-test
|
||||
|
||||
[ 1 2 { [ + ] } first compiled-call2 ] must-fail
|
||||
[ 3 ] [ 1 2 { + } first compiled-execute2 ] unit-test
|
||||
[ 3 ] [ 1 2 '[ _ + ] compiled-call2 ] unit-test
|
||||
[ 3 ] [ 1 2 '[ _ ] [ + ] compose compiled-call2 ] unit-test
|
||||
[ 3 ] [ 1 2 \ + compiled-execute2 ] unit-test
|
||||
|
||||
[ 3 ] [ 1 2 { [ + ] } first call( a b -- c ) ] unit-test
|
||||
[ 3 ] [ 1 2 { + } first execute( a b -- c ) ] unit-test
|
||||
[ 3 ] [ 1 2 '[ _ + ] call( a -- b ) ] unit-test
|
||||
[ 3 ] [ 1 2 '[ _ ] [ + ] compose call( a -- b ) ] unit-test
|
||||
|
||||
[ t ] [ [ 2 '[ _ ] [ + ] compose ] final-info first infer-value (( object -- object )) effect= ] unit-test
|
||||
[ t ] [ [ 2 '[ _ ] 1 '[ _ + ] compose ] final-info first infer-value (( -- object )) effect= ] unit-test
|
||||
[ t ] [ [ 2 '[ _ + ] ] final-info first infer-value (( object -- object )) effect= ] unit-test
|
||||
[ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test
|
||||
[ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test
|
||||
[ f ] [ [ dup drop ] final-info first infer-value ] unit-test
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators combinators.private effects fry
|
||||
kernel kernel.private make sequences continuations quotations
|
||||
stack-checker stack-checker.transforms words math ;
|
||||
IN: stack-checker.call-effect
|
||||
words math stack-checker stack-checker.transforms
|
||||
compiler.tree.propagation.info slots.private ;
|
||||
IN: compiler.tree.propagation.call-effect
|
||||
|
||||
! call( and execute( have complex expansions.
|
||||
|
||||
|
@ -84,18 +85,14 @@ M: quotation cached-effect
|
|||
[ drop call-effect-slow ]
|
||||
if ; inline
|
||||
|
||||
\ call-effect [
|
||||
inline-cache new '[
|
||||
_
|
||||
3dup nip cache-hit? [
|
||||
drop call-effect-unsafe
|
||||
] [
|
||||
call-effect-fast
|
||||
] if
|
||||
]
|
||||
] 0 define-transform
|
||||
: call-effect-ic ( quot effect inline-cache -- )
|
||||
3dup nip cache-hit?
|
||||
[ drop call-effect-unsafe ]
|
||||
[ call-effect-fast ]
|
||||
if ; inline
|
||||
|
||||
\ call-effect t "no-compile" set-word-prop
|
||||
: call-effect>quot ( effect -- quot )
|
||||
inline-cache new '[ drop _ _ call-effect-ic ] ;
|
||||
|
||||
: execute-effect-slow ( word effect -- )
|
||||
[ '[ _ execute ] ] dip call-effect-slow ; inline
|
||||
|
@ -116,8 +113,72 @@ M: quotation cached-effect
|
|||
if ; inline
|
||||
|
||||
: execute-effect>quot ( effect -- quot )
|
||||
inline-cache new '[ _ _ execute-effect-ic ] ;
|
||||
inline-cache new '[ drop _ _ execute-effect-ic ] ;
|
||||
|
||||
\ execute-effect [ execute-effect>quot ] 1 define-transform
|
||||
: last2 ( seq -- penultimate ultimate )
|
||||
2 tail* first2 ;
|
||||
|
||||
\ execute-effect t "no-compile" set-word-prop
|
||||
: top-two ( #call -- effect value )
|
||||
in-d>> last2 [ value-info ] bi@
|
||||
literal>> swap ;
|
||||
|
||||
ERROR: uninferable ;
|
||||
|
||||
: remove-effect-input ( effect -- effect' )
|
||||
(( -- object )) swap compose-effects ;
|
||||
|
||||
: (infer-value) ( value-info -- effect )
|
||||
dup class>> {
|
||||
{ \ quotation [
|
||||
literal>> [ uninferable ] unless* cached-effect
|
||||
dup +unknown+ = [ uninferable ] when
|
||||
] }
|
||||
{ \ curry [
|
||||
slots>> third (infer-value)
|
||||
remove-effect-input
|
||||
] }
|
||||
{ \ compose [
|
||||
slots>> last2 [ (infer-value) ] bi@
|
||||
compose-effects
|
||||
] }
|
||||
[ uninferable ]
|
||||
} case ;
|
||||
|
||||
: infer-value ( value-info -- effect/f )
|
||||
[ (infer-value) ]
|
||||
[ dup uninferable? [ 2drop f ] [ rethrow ] if ]
|
||||
recover ;
|
||||
|
||||
: (value>quot) ( value-info -- quot )
|
||||
dup class>> {
|
||||
{ \ quotation [ literal>> '[ drop @ ] ] }
|
||||
{ \ curry [
|
||||
slots>> third (value>quot)
|
||||
'[ [ obj>> ] [ quot>> @ ] bi ]
|
||||
] }
|
||||
{ \ compose [
|
||||
slots>> last2 [ (value>quot) ] bi@
|
||||
'[ [ first>> @ ] [ second>> @ ] bi ]
|
||||
] }
|
||||
} case ;
|
||||
|
||||
: value>quot ( value-info -- quot: ( code effect -- ) )
|
||||
(value>quot) '[ drop @ ] ;
|
||||
|
||||
: call-inlining ( #call -- quot/f )
|
||||
top-two dup infer-value [
|
||||
pick effect<=
|
||||
[ nip value>quot ]
|
||||
[ drop call-effect>quot ] if
|
||||
] [ drop call-effect>quot ] if* ;
|
||||
|
||||
\ call-effect [ call-inlining ] "custom-inlining" set-word-prop
|
||||
|
||||
: execute-inlining ( #call -- quot/f )
|
||||
top-two >literal< [
|
||||
2dup swap execute-effect-unsafe?
|
||||
[ nip '[ 2drop _ execute ] ]
|
||||
[ drop execute-effect>quot ] if
|
||||
] [ drop execute-effect>quot ] if ;
|
||||
|
||||
\ execute-effect [ execute-inlining ] "custom-inlining" set-word-prop
|
|
@ -6,14 +6,16 @@ math.parser math.order layouts words sequences sequences.private
|
|||
arrays assocs classes classes.algebra combinators generic.math
|
||||
splitting fry locals classes.tuple alien.accessors
|
||||
classes.tuple.private slots.private definitions strings.private
|
||||
vectors hashtables generic
|
||||
vectors hashtables generic quotations
|
||||
stack-checker.state
|
||||
compiler.tree.comparisons
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
compiler.tree.propagation.slots
|
||||
compiler.tree.propagation.simple
|
||||
compiler.tree.propagation.constraints ;
|
||||
compiler.tree.propagation.constraints
|
||||
compiler.tree.propagation.call-effect
|
||||
compiler.tree.propagation.transforms ;
|
||||
IN: compiler.tree.propagation.known-words
|
||||
|
||||
\ fixnum
|
||||
|
@ -226,39 +228,6 @@ generic-comparison-ops [
|
|||
] "outputs" set-word-prop
|
||||
] assoc-each
|
||||
|
||||
: rem-custom-inlining ( #call -- quot/f )
|
||||
second value-info literal>> dup integer?
|
||||
[ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
|
||||
|
||||
{
|
||||
mod-integer-integer
|
||||
mod-integer-fixnum
|
||||
mod-fixnum-integer
|
||||
fixnum-mod
|
||||
} [
|
||||
[
|
||||
in-d>> dup first value-info interval>> [0,inf] interval-subset?
|
||||
[ rem-custom-inlining ] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
\ rem [
|
||||
in-d>> rem-custom-inlining
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
{
|
||||
bitand-integer-integer
|
||||
bitand-integer-fixnum
|
||||
bitand-fixnum-integer
|
||||
} [
|
||||
[
|
||||
in-d>> second value-info >literal< [
|
||||
0 most-positive-fixnum between?
|
||||
[ [ >fixnum ] bi@ fixnum-bitand ] f ?
|
||||
] when
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
{ numerator denominator }
|
||||
[ [ drop integer <class-info> ] "outputs" set-word-prop ] each
|
||||
|
||||
|
@ -313,15 +282,6 @@ generic-comparison-ops [
|
|||
"outputs" set-word-prop
|
||||
] each
|
||||
|
||||
! Generate more efficient code for common idiom
|
||||
\ clone [
|
||||
in-d>> first value-info literal>> {
|
||||
{ V{ } [ [ drop { } 0 vector boa ] ] }
|
||||
{ H{ } [ [ drop 0 <hashtable> ] ] }
|
||||
[ drop f ]
|
||||
} case
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
\ slot [
|
||||
dup literal?>>
|
||||
[ literal>> swap value-info-slot ] [ 2drop object-info ] if
|
||||
|
@ -345,17 +305,3 @@ generic-comparison-ops [
|
|||
bi
|
||||
] [ 2drop object-info ] if
|
||||
] "outputs" set-word-prop
|
||||
|
||||
\ instance? [
|
||||
in-d>> second value-info literal>> dup class?
|
||||
[ "predicate" word-prop '[ drop @ ] ] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
\ equal? [
|
||||
! If first input has a known type and second input is an
|
||||
! object, we convert this to [ swap equal? ].
|
||||
in-d>> first2 value-info class>> object class= [
|
||||
value-info class>> \ equal? specific-method
|
||||
[ swap equal? ] f ?
|
||||
] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
|
|
|
@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
|
|||
compiler.tree.debugger compiler.tree.checker
|
||||
slots.private words hashtables classes assocs locals
|
||||
specialized-arrays.double system sorting math.libm
|
||||
math.intervals quotations ;
|
||||
math.intervals quotations effects ;
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
[ V{ } ] [ [ ] final-classes ] unit-test
|
||||
|
@ -84,9 +84,9 @@ IN: compiler.tree.propagation.tests
|
|||
|
||||
[ float ] [ [ { float float } declare mod ] final-math-class ] unit-test
|
||||
|
||||
[ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
|
||||
[ V{ fixnum } ] [ [ 255 bitand ] final-classes ] unit-test
|
||||
|
||||
[ V{ integer } ] [
|
||||
[ V{ fixnum } ] [
|
||||
[ [ 255 bitand ] [ 65535 bitand ] bi + ] final-classes
|
||||
] unit-test
|
||||
|
||||
|
@ -640,6 +640,10 @@ MIXIN: empty-mixin
|
|||
[ { bignum integer } declare [ shift ] keep ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ fixnum } ] [ [ >fixnum 15 bitand 1 swap shift ] final-classes ] unit-test
|
||||
|
||||
[ V{ fixnum } ] [ [ 15 bitand 1 swap shift ] final-classes ] unit-test
|
||||
|
||||
[ V{ fixnum } ] [
|
||||
[ { fixnum } declare log2 ] final-classes
|
||||
] unit-test
|
||||
|
@ -704,3 +708,39 @@ TUPLE: circle me ;
|
|||
|
||||
! Joe found an oversight
|
||||
[ V{ integer } ] [ [ >integer ] final-classes ] unit-test
|
||||
|
||||
TUPLE: foo bar ;
|
||||
|
||||
[ t ] [ [ foo new ] { new } inlined? ] unit-test
|
||||
|
||||
GENERIC: whatever ( x -- y )
|
||||
M: number whatever drop foo ;
|
||||
|
||||
[ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test
|
||||
|
||||
: that-thing ( -- class ) foo ;
|
||||
|
||||
[ f ] [ [ that-thing new ] { new } inlined? ] unit-test
|
||||
|
||||
GENERIC: whatever2 ( x -- y )
|
||||
M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ;
|
||||
M: f whatever2 ;
|
||||
|
||||
[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
|
||||
[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
|
||||
|
||||
[ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
|
||||
[ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test
|
||||
|
||||
[ t ] [ [ { 1 2 3 } memq? ] { memq? } inlined? ] unit-test
|
||||
[ f ] [ [ { 1 2 3 } swap memq? ] { memq? } inlined? ] unit-test
|
||||
|
||||
[ t ] [ [ V{ } clone ] { clone (clone) } inlined? ] unit-test
|
||||
[ f ] [ [ { } clone ] { clone (clone) } inlined? ] unit-test
|
||||
|
||||
[ f ] [ [ instance? ] { instance? } inlined? ] unit-test
|
||||
[ f ] [ [ 5 instance? ] { instance? } inlined? ] unit-test
|
||||
[ t ] [ [ array instance? ] { instance? } inlined? ] unit-test
|
||||
|
||||
[ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
|
||||
[ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test
|
||||
|
|
|
@ -0,0 +1,2 @@
|
|||
Slava Pestov
|
||||
Daniel Ehrenberg
|
|
@ -0,0 +1,205 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences words fry generic accessors classes.tuple
|
||||
classes classes.algebra definitions stack-checker.state quotations
|
||||
classes.tuple.private math math.partial-dispatch math.private
|
||||
math.intervals layouts math.order vectors hashtables
|
||||
combinators effects generalizations assocs sets
|
||||
combinators.short-circuit sequences.private locals
|
||||
stack-checker namespaces compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.propagation.transforms
|
||||
|
||||
\ equal? [
|
||||
! If first input has a known type and second input is an
|
||||
! object, we convert this to [ swap equal? ].
|
||||
in-d>> first2 value-info class>> object class= [
|
||||
value-info class>> \ equal? specific-method
|
||||
[ swap equal? ] f ?
|
||||
] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
: rem-custom-inlining ( #call -- quot/f )
|
||||
second value-info literal>> dup integer?
|
||||
[ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
|
||||
|
||||
{
|
||||
mod-integer-integer
|
||||
mod-integer-fixnum
|
||||
mod-fixnum-integer
|
||||
fixnum-mod
|
||||
} [
|
||||
[
|
||||
in-d>> dup first value-info interval>> [0,inf] interval-subset?
|
||||
[ rem-custom-inlining ] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
\ rem [
|
||||
in-d>> rem-custom-inlining
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
{
|
||||
bitand-integer-integer
|
||||
bitand-integer-fixnum
|
||||
bitand-fixnum-integer
|
||||
bitand
|
||||
} [
|
||||
[
|
||||
in-d>> second value-info >literal< [
|
||||
0 most-positive-fixnum between?
|
||||
[ [ >fixnum ] bi@ fixnum-bitand ] f ?
|
||||
] when
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
! Speeds up 2^
|
||||
\ shift [
|
||||
in-d>> first value-info literal>> 1 = [
|
||||
cell-bits tag-bits get - 1 -
|
||||
'[
|
||||
>fixnum dup 0 < [ 2drop 0 ] [
|
||||
dup _ < [ fixnum-shift ] [
|
||||
fixnum-shift
|
||||
] if
|
||||
] if
|
||||
]
|
||||
] [ f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
! Generate more efficient code for common idiom
|
||||
\ clone [
|
||||
in-d>> first value-info literal>> {
|
||||
{ V{ } [ [ drop { } 0 vector boa ] ] }
|
||||
{ H{ } [ [ drop 0 <hashtable> ] ] }
|
||||
[ drop f ]
|
||||
} case
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
ERROR: bad-partial-eval quot word ;
|
||||
|
||||
: check-effect ( quot word -- )
|
||||
2dup [ infer ] [ stack-effect ] bi* effect<=
|
||||
[ 2drop ] [ bad-partial-eval ] if ;
|
||||
|
||||
:: define-partial-eval ( word quot n -- )
|
||||
word [
|
||||
in-d>> n tail*
|
||||
[ value-info ] map
|
||||
dup [ literal?>> ] all? [
|
||||
[ literal>> ] map
|
||||
n firstn
|
||||
quot call dup [
|
||||
[ n ndrop ] prepose
|
||||
dup word check-effect
|
||||
] when
|
||||
] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop ;
|
||||
|
||||
: inline-new ( class -- quot/f )
|
||||
dup tuple-class? [
|
||||
dup inlined-dependency depends-on
|
||||
[ all-slots [ initial>> literalize ] map ]
|
||||
[ tuple-layout '[ _ <tuple-boa> ] ]
|
||||
bi append >quotation
|
||||
] [ drop f ] if ;
|
||||
|
||||
\ new [ inline-new ] 1 define-partial-eval
|
||||
|
||||
\ instance? [
|
||||
dup class?
|
||||
[ "predicate" word-prop ] [ drop f ] if
|
||||
] 1 define-partial-eval
|
||||
|
||||
! Shuffling
|
||||
: nths-quot ( indices -- quot )
|
||||
[ [ '[ _ swap nth ] ] map ] [ length ] bi
|
||||
'[ _ cleave _ narray ] ;
|
||||
|
||||
\ shuffle [
|
||||
shuffle-mapping nths-quot
|
||||
] 1 define-partial-eval
|
||||
|
||||
! Index search
|
||||
\ index [
|
||||
dup sequence? [
|
||||
dup length 4 >= [
|
||||
dup length zip >hashtable '[ _ at ]
|
||||
] [ drop f ] if
|
||||
] [ drop f ] if
|
||||
] 1 define-partial-eval
|
||||
|
||||
: memq-quot ( seq -- newquot )
|
||||
[ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
|
||||
[ drop f ] suffix [ cond ] curry ;
|
||||
|
||||
\ memq? [
|
||||
dup sequence? [ memq-quot ] [ drop f ] if
|
||||
] 1 define-partial-eval
|
||||
|
||||
! Membership testing
|
||||
: member-quot ( seq -- newquot )
|
||||
dup length 4 <= [
|
||||
[ drop f ] swap
|
||||
[ literalize [ t ] ] { } map>assoc linear-case-quot
|
||||
] [
|
||||
unique [ key? ] curry
|
||||
] if ;
|
||||
|
||||
\ member? [
|
||||
dup sequence? [ member-quot ] [ drop f ] if
|
||||
] 1 define-partial-eval
|
||||
|
||||
! Fast at for integer maps
|
||||
CONSTANT: lookup-table-at-max 256
|
||||
|
||||
: lookup-table-at? ( assoc -- ? )
|
||||
#! Can we use a fast byte array test here?
|
||||
{
|
||||
[ assoc-size 4 > ]
|
||||
[ values [ ] all? ]
|
||||
[ keys [ integer? ] all? ]
|
||||
[ keys [ 0 lookup-table-at-max between? ] all? ]
|
||||
} 1&& ;
|
||||
|
||||
: lookup-table-seq ( assoc -- table )
|
||||
[ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
|
||||
|
||||
: lookup-table-quot ( seq -- newquot )
|
||||
lookup-table-seq
|
||||
'[
|
||||
_ over integer? [
|
||||
2dup bounds-check? [
|
||||
nth-unsafe dup >boolean
|
||||
] [ 2drop f f ] if
|
||||
] [ 2drop f f ] if
|
||||
] ;
|
||||
|
||||
: fast-lookup-table-at? ( assoc -- ? )
|
||||
values {
|
||||
[ [ integer? ] all? ]
|
||||
[ [ 0 254 between? ] all? ]
|
||||
} 1&& ;
|
||||
|
||||
: fast-lookup-table-seq ( assoc -- table )
|
||||
lookup-table-seq [ 255 or ] B{ } map-as ;
|
||||
|
||||
: fast-lookup-table-quot ( seq -- newquot )
|
||||
fast-lookup-table-seq
|
||||
'[
|
||||
_ over integer? [
|
||||
2dup bounds-check? [
|
||||
nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
|
||||
] [ 2drop f f ] if
|
||||
] [ 2drop f f ] if
|
||||
] ;
|
||||
|
||||
: at-quot ( assoc -- quot )
|
||||
dup lookup-table-at? [
|
||||
dup fast-lookup-table-at? [
|
||||
fast-lookup-table-quot
|
||||
] [
|
||||
lookup-table-quot
|
||||
] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
\ at* [ at-quot ] 1 define-partial-eval
|
|
@ -27,4 +27,6 @@ SYMBOL: yield-hook
|
|||
yield-hook [ [ ] ] initialize
|
||||
|
||||
: alist-max ( alist -- pair )
|
||||
[ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
|
||||
[ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
|
||||
|
||||
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
|
||||
|
|
|
@ -76,18 +76,18 @@ HOOK: %or cpu ( dst src1 src2 -- )
|
|||
HOOK: %or-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %xor cpu ( dst src1 src2 -- )
|
||||
HOOK: %xor-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %shl cpu ( dst src1 src2 -- )
|
||||
HOOK: %shl-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %shr cpu ( dst src1 src2 -- )
|
||||
HOOK: %shr-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %sar cpu ( dst src1 src2 -- )
|
||||
HOOK: %sar-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %not cpu ( dst src -- )
|
||||
HOOK: %log2 cpu ( dst src -- )
|
||||
|
||||
HOOK: %fixnum-add cpu ( src1 src2 -- )
|
||||
HOOK: %fixnum-add-tail cpu ( src1 src2 -- )
|
||||
HOOK: %fixnum-sub cpu ( src1 src2 -- )
|
||||
HOOK: %fixnum-sub-tail cpu ( src1 src2 -- )
|
||||
HOOK: %fixnum-mul cpu ( src1 src2 temp1 temp2 -- )
|
||||
HOOK: %fixnum-mul-tail cpu ( src1 src2 temp1 temp2 -- )
|
||||
HOOK: %fixnum-add cpu ( label dst src1 src2 -- )
|
||||
HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
|
||||
HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )
|
||||
|
||||
HOOK: %integer>bignum cpu ( dst src temp -- )
|
||||
HOOK: %bignum>integer cpu ( dst src temp -- )
|
||||
|
|
|
@ -51,8 +51,6 @@ M: x86.32 reserved-area-size 0 ;
|
|||
|
||||
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
|
||||
|
||||
M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ;
|
||||
|
||||
M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
||||
c-type
|
||||
[ return-in-registers?>> ]
|
||||
|
|
|
@ -167,11 +167,6 @@ M: x86.64 %alien-invoke
|
|||
rc-absolute-cell rel-dlsym
|
||||
R11 CALL ;
|
||||
|
||||
M: x86.64 %alien-invoke-tail
|
||||
R11 0 MOV
|
||||
rc-absolute-cell rel-dlsym
|
||||
R11 JMP ;
|
||||
|
||||
M: x86.64 %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
RBP RAX MOV ;
|
||||
|
|
|
@ -4,9 +4,14 @@ USING: accessors assocs alien alien.c-types arrays strings
|
|||
cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
|
||||
kernel kernel.private math memory namespaces make sequences
|
||||
words system layouts combinators math.order fry locals
|
||||
compiler.constants compiler.cfg.registers
|
||||
compiler.cfg.instructions compiler.cfg.intrinsics
|
||||
compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup ;
|
||||
compiler.constants
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.intrinsics
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.stack-frame
|
||||
compiler.codegen
|
||||
compiler.codegen.fixup ;
|
||||
IN: cpu.x86
|
||||
|
||||
<< enable-fixnum-log2 >>
|
||||
|
@ -124,83 +129,18 @@ M: x86 %log2 BSR ;
|
|||
: ?MOV ( dst src -- )
|
||||
2dup = [ 2drop ] [ MOV ] if ; inline
|
||||
|
||||
:: move>args ( src1 src2 -- )
|
||||
{
|
||||
{ [ src1 param-reg-2 = ] [ param-reg-1 src2 ?MOV param-reg-1 param-reg-2 XCHG ] }
|
||||
{ [ src1 param-reg-1 = ] [ param-reg-2 src2 ?MOV ] }
|
||||
{ [ src2 param-reg-1 = ] [ param-reg-2 src1 ?MOV param-reg-1 param-reg-2 XCHG ] }
|
||||
{ [ src2 param-reg-2 = ] [ param-reg-1 src1 ?MOV ] }
|
||||
[
|
||||
param-reg-1 src1 MOV
|
||||
param-reg-2 src2 MOV
|
||||
]
|
||||
} cond ;
|
||||
|
||||
HOOK: %alien-invoke-tail cpu ( func dll -- )
|
||||
|
||||
:: overflow-template ( src1 src2 insn inverse func -- )
|
||||
<label> "no-overflow" set
|
||||
:: overflow-template ( label dst src1 src2 insn -- )
|
||||
src1 src2 insn call
|
||||
ds-reg [] src1 MOV
|
||||
"no-overflow" get JNO
|
||||
src1 src2 inverse call
|
||||
src1 src2 move>args
|
||||
%prepare-alien-invoke
|
||||
func f %alien-invoke
|
||||
"no-overflow" resolve-label ; inline
|
||||
label JO ; inline
|
||||
|
||||
:: overflow-template-tail ( src1 src2 insn inverse func -- )
|
||||
<label> "no-overflow" set
|
||||
src1 src2 insn call
|
||||
"no-overflow" get JNO
|
||||
src1 src2 inverse call
|
||||
src1 src2 move>args
|
||||
%prepare-alien-invoke
|
||||
func f %alien-invoke-tail
|
||||
"no-overflow" resolve-label
|
||||
ds-reg [] src1 MOV
|
||||
0 RET ; inline
|
||||
M: x86 %fixnum-add ( label dst src1 src2 -- )
|
||||
[ ADD ] overflow-template ;
|
||||
|
||||
M: x86 %fixnum-add ( src1 src2 -- )
|
||||
[ ADD ] [ SUB ] "overflow_fixnum_add" overflow-template ;
|
||||
M: x86 %fixnum-sub ( label dst src1 src2 -- )
|
||||
[ SUB ] overflow-template ;
|
||||
|
||||
M: x86 %fixnum-add-tail ( src1 src2 -- )
|
||||
[ ADD ] [ SUB ] "overflow_fixnum_add" overflow-template-tail ;
|
||||
|
||||
M: x86 %fixnum-sub ( src1 src2 -- )
|
||||
[ SUB ] [ ADD ] "overflow_fixnum_subtract" overflow-template ;
|
||||
|
||||
M: x86 %fixnum-sub-tail ( src1 src2 -- )
|
||||
[ SUB ] [ ADD ] "overflow_fixnum_subtract" overflow-template-tail ;
|
||||
|
||||
M:: x86 %fixnum-mul ( src1 src2 temp1 temp2 -- )
|
||||
"no-overflow" define-label
|
||||
temp1 src1 MOV
|
||||
temp1 tag-bits get SAR
|
||||
src2 temp1 IMUL2
|
||||
ds-reg [] temp1 MOV
|
||||
"no-overflow" get JNO
|
||||
src1 src2 move>args
|
||||
param-reg-1 tag-bits get SAR
|
||||
param-reg-2 tag-bits get SAR
|
||||
%prepare-alien-invoke
|
||||
"overflow_fixnum_multiply" f %alien-invoke
|
||||
"no-overflow" resolve-label ;
|
||||
|
||||
M:: x86 %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
|
||||
"overflow" define-label
|
||||
temp1 src1 MOV
|
||||
temp1 tag-bits get SAR
|
||||
src2 temp1 IMUL2
|
||||
"overflow" get JO
|
||||
ds-reg [] temp1 MOV
|
||||
0 RET
|
||||
"overflow" resolve-label
|
||||
src1 src2 move>args
|
||||
param-reg-1 tag-bits get SAR
|
||||
param-reg-2 tag-bits get SAR
|
||||
%prepare-alien-invoke
|
||||
"overflow_fixnum_multiply" f %alien-invoke-tail ;
|
||||
M: x86 %fixnum-mul ( label dst src1 src2 -- )
|
||||
[ swap IMUL2 ] overflow-template ;
|
||||
|
||||
: bignum@ ( reg n -- op )
|
||||
cells bignum tag-number - [+] ; inline
|
||||
|
@ -411,6 +351,28 @@ M: x86.64 small-reg-native small-reg-8 ;
|
|||
[ quot call ] with-save/restore
|
||||
] if ; inline
|
||||
|
||||
: shift-count? ( reg -- ? ) { ECX RCX } memq? ;
|
||||
|
||||
:: emit-shift ( dst src1 src2 quot -- )
|
||||
src2 shift-count? [
|
||||
dst CL quot call
|
||||
] [
|
||||
dst shift-count? [
|
||||
dst src2 XCHG
|
||||
src2 CL quot call
|
||||
dst src2 XCHG
|
||||
] [
|
||||
ECX small-reg-native [
|
||||
CL src2 MOV
|
||||
drop dst CL quot call
|
||||
] with-save/restore
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
M: x86 %shl [ SHL ] emit-shift ;
|
||||
M: x86 %shr [ SHR ] emit-shift ;
|
||||
M: x86 %sar [ SAR ] emit-shift ;
|
||||
|
||||
M:: x86 %string-nth ( dst src index temp -- )
|
||||
"end" define-label
|
||||
dst { src index temp } [| new-dst |
|
||||
|
|
|
@ -258,6 +258,12 @@ M: no-word-error summary
|
|||
|
||||
M: no-word-error error. summary print ;
|
||||
|
||||
M: no-word-in-vocab summary
|
||||
[ vocab>> ] [ word>> ] bi
|
||||
[ "No word named ``" % % "'' found in ``" % % "'' vocabulary" % ] "" make ;
|
||||
|
||||
M: no-word-in-vocab error. summary print ;
|
||||
|
||||
M: ambiguous-use-error summary
|
||||
words>> first name>>
|
||||
"More than one vocabulary defines a word named ``" "''" surround ;
|
||||
|
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays classes.mixin classes.parser
|
||||
classes.tuple classes.tuple.parser combinators effects
|
||||
effects.parser fry generic generic.parser generic.standard
|
||||
interpolate io.streams.string kernel lexer locals.parser
|
||||
locals.rewrite.closures locals.types make namespaces parser
|
||||
quotations sequences vocabs.parser words words.symbol ;
|
||||
USING: accessors arrays classes.mixin classes.parser classes.singleton
|
||||
classes.tuple classes.tuple.parser combinators effects effects.parser
|
||||
fry generic generic.parser generic.standard interpolate
|
||||
io.streams.string kernel lexer locals.parser locals.rewrite.closures
|
||||
locals.types make namespaces parser quotations sequences vocabs.parser
|
||||
words words.symbol ;
|
||||
IN: functors
|
||||
|
||||
! This is a hack
|
||||
|
@ -71,6 +71,14 @@ SYNTAX: `TUPLE:
|
|||
} case
|
||||
\ define-tuple-class parsed ;
|
||||
|
||||
SYNTAX: `SINGLETON:
|
||||
scan-param parsed
|
||||
\ define-singleton-class parsed ;
|
||||
|
||||
SYNTAX: `MIXIN:
|
||||
scan-param parsed
|
||||
\ define-mixin-class parsed ;
|
||||
|
||||
SYNTAX: `M:
|
||||
scan-param parsed
|
||||
scan-param parsed
|
||||
|
@ -134,6 +142,8 @@ DEFER: ;FUNCTOR delimiter
|
|||
: functor-words ( -- assoc )
|
||||
H{
|
||||
{ "TUPLE:" POSTPONE: `TUPLE: }
|
||||
{ "SINGLETON:" POSTPONE: `SINGLETON: }
|
||||
{ "MIXIN:" POSTPONE: `MIXIN: }
|
||||
{ "M:" POSTPONE: `M: }
|
||||
{ "C:" POSTPONE: `C: }
|
||||
{ ":" POSTPONE: `: }
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math sequences arrays assocs sequences.private
|
||||
growable accessors math.order summary ;
|
||||
growable accessors math.order summary vectors ;
|
||||
IN: heaps
|
||||
|
||||
GENERIC: heap-push* ( value key heap -- entry )
|
||||
|
@ -15,14 +15,14 @@ GENERIC: heap-size ( heap -- n )
|
|||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: heap data ;
|
||||
TUPLE: heap { data vector } ;
|
||||
|
||||
: <heap> ( class -- heap )
|
||||
[ V{ } clone ] dip boa ; inline
|
||||
|
||||
TUPLE: entry value key heap index ;
|
||||
|
||||
: <entry> ( value key heap -- entry ) f entry boa ;
|
||||
: <entry> ( value key heap -- entry ) f entry boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
@ -109,10 +109,10 @@ DEFER: up-heap
|
|||
[ data-exchange ] 2keep up-heap
|
||||
] [
|
||||
3drop
|
||||
] if ;
|
||||
] if ; inline recursive
|
||||
|
||||
: up-heap ( n heap -- )
|
||||
over 0 > [ (up-heap) ] [ 2drop ] if ;
|
||||
over 0 > [ (up-heap) ] [ 2drop ] if ; inline recursive
|
||||
|
||||
: (child) ( m heap -- n )
|
||||
2dup right-value
|
||||
|
@ -132,10 +132,10 @@ DEFER: down-heap
|
|||
3drop
|
||||
] [
|
||||
[ data-exchange ] 2keep down-heap
|
||||
] if ;
|
||||
] if ; inline recursive
|
||||
|
||||
: down-heap ( m heap -- )
|
||||
2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ;
|
||||
2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ; inline recursive
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
@ -148,7 +148,7 @@ M: heap heap-push* ( value key heap -- entry )
|
|||
[ swapd heap-push ] curry assoc-each ;
|
||||
|
||||
: >entry< ( entry -- key value )
|
||||
[ value>> ] [ key>> ] bi ;
|
||||
[ value>> ] [ key>> ] bi ; inline
|
||||
|
||||
M: heap heap-peek ( heap -- value key )
|
||||
data-first >entry< ;
|
||||
|
|
|
@ -143,7 +143,7 @@ SYMBOL: vocab-articles
|
|||
swap '[
|
||||
_ elements [
|
||||
rest { { } { "" } } member?
|
||||
[ "Empty description" throw ] when
|
||||
[ "Empty $description" simple-lint-error ] when
|
||||
] each
|
||||
] each ;
|
||||
|
||||
|
|
|
@ -120,7 +120,7 @@ IN: math.matrices
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ;
|
||||
: cross ( vec1 vec2 -- vec3 ) [ [ i ] [ j ] [ k ] 2tri ] keep 3sequence ;
|
||||
|
||||
: proj ( v u -- w )
|
||||
[ [ v. ] [ norm-sq ] bi / ] keep n*v ;
|
||||
|
|
|
@ -0,0 +1,41 @@
|
|||
USING: alien help.markup help.syntax io kernel math quotations
|
||||
opengl.gl assocs vocabs.loader sequences accessors colors words
|
||||
opengl ;
|
||||
IN: opengl.annotations
|
||||
|
||||
HELP: log-gl-error
|
||||
{ $values { "function" word } }
|
||||
{ $description "If the most recent OpenGL call resulted in an error, append it to the " { $link gl-error-log } "." }
|
||||
{ $notes "Don't call this function directly. Call " { $link log-gl-errors } " to annotate every OpenGL function to automatically log errors." } ;
|
||||
|
||||
HELP: gl-error-log
|
||||
{ $var-description "A vector of OpenGL errors logged by " { $link log-gl-errors } ". Each log entry has the following tuple slots:" }
|
||||
{ $list
|
||||
{ { $snippet "function" } " is the OpenGL function that raised the error." }
|
||||
{ { $snippet "error" } " is the OpenGL error code." }
|
||||
{ { $snippet "timestamp" } " is the time the error was logged." }
|
||||
}
|
||||
{ "The error log is emptied using the " { $link clear-gl-error-log } " word." } ;
|
||||
|
||||
HELP: clear-gl-error-log
|
||||
{ $description "Empties the OpenGL error log populated by " { $link log-gl-errors } "." } ;
|
||||
|
||||
HELP: throw-gl-errors
|
||||
{ $description "Annotate every OpenGL function to throw a " { $link gl-error } " if the function results in an error. Use " { $link reset-gl-functions } " to reverse this operation." } ;
|
||||
|
||||
HELP: log-gl-errors
|
||||
{ $description "Annotate every OpenGL function to log using " { $link log-gl-error } " if the function results in an error. Use " { $link reset-gl-functions } " to reverse this operation." } ;
|
||||
|
||||
HELP: reset-gl-functions
|
||||
{ $description "Removes any annotations from all OpenGL functions, such as those applied by " { $link throw-gl-errors } " or " { $link log-gl-errors } "." } ;
|
||||
|
||||
{ throw-gl-errors gl-error log-gl-errors log-gl-error clear-gl-error-log reset-gl-functions } related-words
|
||||
|
||||
ARTICLE: "opengl.annotations" "OpenGL error reporting"
|
||||
"The " { $vocab-link "opengl.annotations" } " vocabulary provides some tools for tracking down GL errors:"
|
||||
{ $subsection throw-gl-errors }
|
||||
{ $subsection log-gl-errors }
|
||||
{ $subsection clear-gl-error-log }
|
||||
{ $subsection reset-gl-functions } ;
|
||||
|
||||
ABOUT: "opengl.annotations"
|
|
@ -0,0 +1,42 @@
|
|||
! Copyright (C) 2009 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces combinators.short-circuit vocabs sequences
|
||||
compiler.units tools.annotations tools.annotations.private fry words
|
||||
opengl calendar accessors ascii ;
|
||||
IN: opengl.annotations
|
||||
|
||||
TUPLE: gl-error-log
|
||||
{ function word initial: t }
|
||||
{ error gl-error }
|
||||
{ timestamp timestamp } ;
|
||||
|
||||
gl-error-log [ V{ } clone ] initialize
|
||||
|
||||
: <gl-error-log> ( function code -- gl-error-log )
|
||||
[ dup ] dip <gl-error> now gl-error-log boa ;
|
||||
|
||||
: log-gl-error ( function -- )
|
||||
gl-error-code [ <gl-error-log> gl-error-log get push ] [ drop ] if* ;
|
||||
|
||||
: clear-gl-error-log ( -- )
|
||||
V{ } clone gl-error-log set ;
|
||||
|
||||
: gl-function? ( word -- ? )
|
||||
name>> { [ "glGetError" = not ] [ "gl" head? ] [ third LETTER? ] } 1&& ;
|
||||
|
||||
: gl-functions ( -- words )
|
||||
"opengl.gl" vocab words [ gl-function? ] filter ;
|
||||
|
||||
: annotate-gl-functions ( quot -- )
|
||||
[
|
||||
[ gl-functions ] dip [ [ dup ] dip curry (annotate) ] curry each
|
||||
] with-compilation-unit ;
|
||||
|
||||
: reset-gl-functions ( -- )
|
||||
[ gl-functions [ (reset) ] each ] with-compilation-unit ;
|
||||
|
||||
: throw-gl-errors ( -- )
|
||||
[ '[ @ _ (gl-error) ] ] annotate-gl-functions ;
|
||||
|
||||
: log-gl-errors ( -- )
|
||||
[ '[ @ _ log-gl-error ] ] annotate-gl-functions ;
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
|
@ -0,0 +1,36 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: help.markup help.syntax multiline tools.continuations ;
|
||||
IN: opengl.debug
|
||||
|
||||
HELP: G
|
||||
{ $description "Makes the OpenGL context associated with " { $link G-world } " active for subsequent OpenGL calls. This is intended to be used from the listener, where interactively entered OpenGL calls can be directed to any window. Note that the Factor UI resets the OpenGL context every time a window is updated, so every code snippet entered in the listener must be prefixed with " { $snippet "G" } " in this use case." }
|
||||
{ $examples { $code <" USING: opengl.debug ui ;
|
||||
|
||||
[ drop t ] find-window G-world set
|
||||
G 0.0 0.0 1.0 1.0 glClearColor
|
||||
G GL_COLOR_BUFFER_BIT glClear
|
||||
"> } } ;
|
||||
|
||||
HELP: F
|
||||
{ $description "Flushes the OpenGL context associated with " { $link G-world } ", thereby committing any outstanding drawing operations." } ;
|
||||
|
||||
HELP: G-world
|
||||
{ $var-description "The world whose OpenGL context is made active by " { $link G } "." } ;
|
||||
|
||||
HELP: GB
|
||||
{ $description "A shorthand for " { $link gl-break } "." } ;
|
||||
|
||||
HELP: gl-break
|
||||
{ $description "Suspends the current thread and activates the walker like " { $link break } ", but also preserves the current OpenGL context, saves it to " { $link G-world } " for interactive use through " { $link G } ", and restores the current context when the suspended thread is continued. The shorthand word " { $link POSTPONE: GB } " can also be used." } ;
|
||||
|
||||
{ G F G-world POSTPONE: GB gl-break } related-words
|
||||
|
||||
ARTICLE: "opengl.debug" "Interactive debugging of OpenGL applications"
|
||||
"The " { $vocab-link "opengl.debug" } " vocabulary provides words to assist with interactive debugging of OpenGL applications in the Factor UI."
|
||||
{ $subsection G-world }
|
||||
{ $subsection G }
|
||||
{ $subsection F }
|
||||
{ $subsection GB }
|
||||
{ $subsection gl-break } ;
|
||||
|
||||
ABOUT: "opengl.debug"
|
|
@ -0,0 +1,23 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors kernel namespaces parser tools.continuations
|
||||
ui.backend ui.gadgets.worlds words ;
|
||||
IN: opengl.debug
|
||||
|
||||
SYMBOL: G-world
|
||||
|
||||
: G ( -- )
|
||||
G-world get set-gl-context ;
|
||||
|
||||
: F ( -- )
|
||||
G-world get handle>> flush-gl-context ;
|
||||
|
||||
: gl-break ( -- )
|
||||
world get dup G-world set-global
|
||||
[ break ] dip
|
||||
set-gl-context ;
|
||||
|
||||
<< \ gl-break t "break?" set-word-prop >>
|
||||
|
||||
SYNTAX: GB
|
||||
\ gl-break parsed ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Helper words for breaking and interactively manipulating OpenGL applications
|
|
@ -1,5 +1,5 @@
|
|||
USING: alien help.markup help.syntax io kernel math quotations
|
||||
opengl.gl assocs vocabs.loader sequences accessors colors ;
|
||||
opengl.gl assocs vocabs.loader sequences accessors colors words ;
|
||||
IN: opengl
|
||||
|
||||
HELP: gl-color
|
||||
|
@ -8,7 +8,7 @@ HELP: gl-color
|
|||
{ $notes "See " { $link "colors" } "." } ;
|
||||
|
||||
HELP: gl-error
|
||||
{ $description "If the most recent OpenGL call resulted in an error, print the error to " { $link output-stream } "." } ;
|
||||
{ $description "If the most recent OpenGL call resulted in an error, throw a " { $snippet "gl-error" } " instance reporting the error." } ;
|
||||
|
||||
HELP: do-enabled
|
||||
{ $values { "what" integer } { "quot" quotation } }
|
||||
|
@ -73,6 +73,8 @@ ARTICLE: "gl-utilities" "OpenGL utility words"
|
|||
$nl
|
||||
"The " { $vocab-link "opengl.gl" } " and " { $vocab-link "opengl.glu" } " vocabularies have the actual OpenGL bindings."
|
||||
{ $subsection "opengl-low-level" }
|
||||
"Error reporting:"
|
||||
{ $subsection gl-error }
|
||||
"Wrappers:"
|
||||
{ $subsection gl-color }
|
||||
{ $subsection gl-translate }
|
||||
|
|
|
@ -2,9 +2,10 @@
|
|||
! Portions copyright (C) 2007 Eduardo Cavazos.
|
||||
! Portions copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types continuations kernel libc math macros
|
||||
namespaces math.vectors math.parser opengl.gl combinators
|
||||
combinators.smart arrays sequences splitting words byte-arrays assocs
|
||||
USING: alien alien.c-types ascii calendar combinators.short-circuit
|
||||
continuations kernel libc math macros namespaces math.vectors
|
||||
math.parser opengl.gl combinators combinators.smart arrays
|
||||
sequences splitting words byte-arrays assocs vocabs
|
||||
colors colors.constants accessors generalizations locals fry
|
||||
specialized-arrays.float specialized-arrays.uint ;
|
||||
IN: opengl
|
||||
|
@ -28,12 +29,19 @@ IN: opengl
|
|||
{ HEX: 0506 "Invalid framebuffer operation" }
|
||||
} at "Unknown error" or ;
|
||||
|
||||
TUPLE: gl-error code string ;
|
||||
TUPLE: gl-error function code string ;
|
||||
|
||||
: <gl-error> ( function code -- gl-error )
|
||||
dup error>string \ gl-error boa ; inline
|
||||
|
||||
: gl-error-code ( -- code/f )
|
||||
glGetError dup 0 = [ drop f ] when ; inline
|
||||
|
||||
: (gl-error) ( function -- )
|
||||
gl-error-code [ <gl-error> throw ] [ drop ] if* ;
|
||||
|
||||
: gl-error ( -- )
|
||||
glGetError dup 0 = [ drop ] [
|
||||
dup error>string \ gl-error boa throw
|
||||
] if ;
|
||||
f (gl-error) ; inline
|
||||
|
||||
: do-enabled ( what quot -- )
|
||||
over glEnable dip glDisable ; inline
|
||||
|
|
|
@ -1,5 +1,4 @@
|
|||
USE: specialized-arrays.functor
|
||||
IN: specialized-arrays.alien
|
||||
|
||||
<< "void*" define-array >>
|
||||
<< "ptrdiff_t" define-array >>
|
||||
<< "void*" define-array >>
|
|
@ -0,0 +1,4 @@
|
|||
USE: specialized-arrays.functor
|
||||
IN: specialized-arrays.alien
|
||||
|
||||
<< "ptrdiff_t" define-array >>
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: functors sequences sequences.private growable
|
||||
USING: accessors alien.c-types functors sequences sequences.private growable
|
||||
prettyprint.custom kernel words classes math parser ;
|
||||
QUALIFIED: vectors.functor
|
||||
IN: specialized-vectors.functor
|
||||
|
@ -21,6 +21,8 @@ V A <A> vectors.functor:define-vector
|
|||
|
||||
M: V contract 2drop ;
|
||||
|
||||
M: V byte-length underlying>> byte-length ;
|
||||
|
||||
M: V pprint-delims drop \ V{ \ } ;
|
||||
|
||||
M: V >pprint-sequence ;
|
||||
|
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
|
@ -1,16 +0,0 @@
|
|||
USING: stack-checker.call-effect tools.test kernel math effects ;
|
||||
IN: stack-checker.call-effect.tests
|
||||
|
||||
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
|
||||
[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
|
||||
[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
|
||||
[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
|
||||
|
||||
[ t ] [ [ + ] cached-effect (( a b -- c )) effect= ] unit-test
|
||||
[ t ] [ 5 [ + ] curry cached-effect (( a -- c )) effect= ] unit-test
|
||||
[ t ] [ 5 [ ] curry cached-effect (( -- c )) effect= ] unit-test
|
||||
[ t ] [ [ dup ] [ drop ] compose cached-effect (( a -- b )) effect= ] unit-test
|
||||
[ t ] [ [ drop ] [ dup ] compose cached-effect (( a b -- c d )) effect= ] unit-test
|
||||
[ t ] [ [ 2drop ] [ dup ] compose cached-effect (( a b c -- d e )) effect= ] unit-test
|
||||
[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect (( -- a )) effect= ] unit-test
|
||||
[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect (( a -- )) effect= ] unit-test
|
|
@ -1 +1,2 @@
|
|||
Slava Pestov
|
||||
Daniel Ehrenberg
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors alien alien.accessors arrays byte-arrays classes
|
||||
continuations.private effects generic hashtables
|
||||
|
@ -67,12 +67,18 @@ IN: stack-checker.known-words
|
|||
[ length ensure-d ] keep zip
|
||||
#declare, ;
|
||||
|
||||
\ declare [ infer-declare ] "special" set-word-prop
|
||||
|
||||
GENERIC: infer-call* ( value known -- )
|
||||
|
||||
: (infer-call) ( value -- ) dup known infer-call* ;
|
||||
|
||||
: infer-call ( -- ) pop-d (infer-call) ;
|
||||
|
||||
\ call [ infer-call ] "special" set-word-prop
|
||||
|
||||
\ (call) [ infer-call ] "special" set-word-prop
|
||||
|
||||
M: literal infer-call*
|
||||
[ 1array #drop, ] [ infer-literal-quot ] bi* ;
|
||||
|
||||
|
@ -103,10 +109,16 @@ M: object infer-call*
|
|||
|
||||
: infer-dip ( -- ) \ dip 1 infer-ndip ;
|
||||
|
||||
\ dip [ infer-dip ] "special" set-word-prop
|
||||
|
||||
: infer-2dip ( -- ) \ 2dip 2 infer-ndip ;
|
||||
|
||||
\ 2dip [ infer-2dip ] "special" set-word-prop
|
||||
|
||||
: infer-3dip ( -- ) \ 3dip 3 infer-ndip ;
|
||||
|
||||
\ 3dip [ infer-3dip ] "special" set-word-prop
|
||||
|
||||
: infer-builder ( quot word -- )
|
||||
[
|
||||
[ 2 consume-d ] dip
|
||||
|
@ -116,8 +128,12 @@ M: object infer-call*
|
|||
|
||||
: infer-curry ( -- ) [ <curried> ] \ curry infer-builder ;
|
||||
|
||||
\ curry [ infer-curry ] "special" set-word-prop
|
||||
|
||||
: infer-compose ( -- ) [ <composed> ] \ compose infer-builder ;
|
||||
|
||||
\ compose [ infer-compose ] "special" set-word-prop
|
||||
|
||||
: infer-execute ( -- )
|
||||
pop-literal nip
|
||||
dup word? [
|
||||
|
@ -127,11 +143,17 @@ M: object infer-call*
|
|||
"execute must be given a word" time-bomb
|
||||
] if ;
|
||||
|
||||
\ execute [ infer-execute ] "special" set-word-prop
|
||||
|
||||
\ (execute) [ infer-execute ] "special" set-word-prop
|
||||
|
||||
: infer-<tuple-boa> ( -- )
|
||||
\ <tuple-boa>
|
||||
peek-d literal value>> second 1+ { tuple } <effect>
|
||||
apply-word/effect ;
|
||||
|
||||
\ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
|
||||
|
||||
: infer-effect-unsafe ( word -- )
|
||||
pop-literal nip
|
||||
add-effect-input
|
||||
|
@ -140,17 +162,30 @@ M: object infer-call*
|
|||
: infer-execute-effect-unsafe ( -- )
|
||||
\ (execute) infer-effect-unsafe ;
|
||||
|
||||
\ execute-effect-unsafe [ infer-execute-effect-unsafe ] "special" set-word-prop
|
||||
|
||||
: infer-call-effect-unsafe ( -- )
|
||||
\ call infer-effect-unsafe ;
|
||||
|
||||
\ call-effect-unsafe [ infer-call-effect-unsafe ] "special" set-word-prop
|
||||
|
||||
: infer-exit ( -- )
|
||||
\ exit (( n -- * )) apply-word/effect ;
|
||||
|
||||
\ exit [ infer-exit ] "special" set-word-prop
|
||||
|
||||
: infer-load-locals ( -- )
|
||||
pop-literal nip
|
||||
consume-d dup copy-values dup output-r
|
||||
[ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
|
||||
|
||||
\ load-locals [ infer-load-locals ] "special" set-word-prop
|
||||
|
||||
: infer-load-local ( -- )
|
||||
1 infer->r ;
|
||||
|
||||
\ load-local [ infer-load-local ] "special" set-word-prop
|
||||
|
||||
: infer-get-local ( -- )
|
||||
[let* | n [ pop-literal nip 1 swap - ]
|
||||
in-r [ n consume-r ]
|
||||
|
@ -163,36 +198,34 @@ M: object infer-call*
|
|||
#shuffle,
|
||||
] ;
|
||||
|
||||
\ get-local [ infer-get-local ] "special" set-word-prop
|
||||
|
||||
: infer-drop-locals ( -- )
|
||||
f f pop-literal nip consume-r f f #shuffle, ;
|
||||
|
||||
\ drop-locals [ infer-drop-locals ] "special" set-word-prop
|
||||
|
||||
: infer-call-effect ( word -- )
|
||||
1 ensure-d first literal value>>
|
||||
add-effect-input add-effect-input
|
||||
apply-word/effect ;
|
||||
|
||||
{ call-effect execute-effect } [
|
||||
dup t "no-compile" set-word-prop
|
||||
dup '[ _ infer-call-effect ] "special" set-word-prop
|
||||
] each
|
||||
|
||||
\ do-primitive [ unknown-primitive-error ] "special" set-word-prop
|
||||
|
||||
\ if [ infer-if ] "special" set-word-prop
|
||||
\ dispatch [ infer-dispatch ] "special" set-word-prop
|
||||
|
||||
\ alien-invoke [ infer-alien-invoke ] "special" set-word-prop
|
||||
\ alien-indirect [ infer-alien-indirect ] "special" set-word-prop
|
||||
\ alien-callback [ infer-alien-callback ] "special" set-word-prop
|
||||
|
||||
: infer-special ( word -- )
|
||||
{
|
||||
{ \ declare [ infer-declare ] }
|
||||
{ \ call [ infer-call ] }
|
||||
{ \ (call) [ infer-call ] }
|
||||
{ \ dip [ infer-dip ] }
|
||||
{ \ 2dip [ infer-2dip ] }
|
||||
{ \ 3dip [ infer-3dip ] }
|
||||
{ \ curry [ infer-curry ] }
|
||||
{ \ compose [ infer-compose ] }
|
||||
{ \ execute [ infer-execute ] }
|
||||
{ \ (execute) [ infer-execute ] }
|
||||
{ \ execute-effect-unsafe [ infer-execute-effect-unsafe ] }
|
||||
{ \ call-effect-unsafe [ infer-call-effect-unsafe ] }
|
||||
{ \ if [ infer-if ] }
|
||||
{ \ dispatch [ infer-dispatch ] }
|
||||
{ \ <tuple-boa> [ infer-<tuple-boa> ] }
|
||||
{ \ exit [ infer-exit ] }
|
||||
{ \ load-local [ 1 infer->r ] }
|
||||
{ \ load-locals [ infer-load-locals ] }
|
||||
{ \ get-local [ infer-get-local ] }
|
||||
{ \ drop-locals [ infer-drop-locals ] }
|
||||
{ \ do-primitive [ unknown-primitive-error ] }
|
||||
{ \ alien-invoke [ infer-alien-invoke ] }
|
||||
{ \ alien-indirect [ infer-alien-indirect ] }
|
||||
{ \ alien-callback [ infer-alien-callback ] }
|
||||
} case ;
|
||||
"special" word-prop call( -- ) ;
|
||||
|
||||
: infer-local-reader ( word -- )
|
||||
(( -- value )) apply-word/effect ;
|
||||
|
@ -209,10 +242,7 @@ M: object infer-call*
|
|||
dispatch <tuple-boa> exit load-local load-locals get-local
|
||||
drop-locals do-primitive alien-invoke alien-indirect
|
||||
alien-callback
|
||||
} [
|
||||
[ t "special" set-word-prop ]
|
||||
[ t "no-compile" set-word-prop ] bi
|
||||
] each
|
||||
} [ t "no-compile" set-word-prop ] each
|
||||
|
||||
! Exceptions to the above
|
||||
\ curry f "no-compile" set-word-prop
|
||||
|
@ -662,4 +692,4 @@ M: object infer-call*
|
|||
\ reset-inline-cache-stats { } { } define-primitive
|
||||
\ inline-cache-stats { } { array } define-primitive
|
||||
|
||||
\ optimized? { word } { object } define-primitive
|
||||
\ optimized? { word } { object } define-primitive
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue