add crappy experimental code for compiler.cfg.graphviz & compiler.cfg.gvn
Alex Vondrak
John Benediktsson
parent
7873719c6e
commit
64b541759e
|
|
@ -0,0 +1,89 @@
|
||||||
|
! Copyright (C) 2011 Alex Vondrak.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license
|
||||||
|
|
||||||
|
USING: accessors fry io io.streams.string kernel math.parser
|
||||||
|
namespaces prettyprint sequences splitting strings
|
||||||
|
tools.annotations
|
||||||
|
|
||||||
|
compiler.cfg
|
||||||
|
compiler.cfg.builder
|
||||||
|
compiler.cfg.debugger
|
||||||
|
compiler.cfg.linearization
|
||||||
|
compiler.cfg.finalization
|
||||||
|
compiler.cfg.optimizer
|
||||||
|
compiler.cfg.rpo
|
||||||
|
|
||||||
|
compiler.cfg.value-numbering
|
||||||
|
compiler.cfg.value-numbering.graph
|
||||||
|
|
||||||
|
graphviz
|
||||||
|
graphviz.notation
|
||||||
|
graphviz.render
|
||||||
|
;
|
||||||
|
FROM: compiler.cfg.linearization => number-blocks ;
|
||||||
|
IN: compiler.cfg.graphviz
|
||||||
|
|
||||||
|
: left-justify ( str -- str' )
|
||||||
|
string-lines "\\l" join ;
|
||||||
|
|
||||||
|
: bb-label ( bb -- str )
|
||||||
|
[
|
||||||
|
instructions>> [ insn. ] each
|
||||||
|
] with-string-writer left-justify ;
|
||||||
|
|
||||||
|
: add-cfg-vertex ( graph bb -- graph' )
|
||||||
|
[ number>> <node> ]
|
||||||
|
[ bb-label =label ]
|
||||||
|
[ kill-block?>> [ "grey" =color "filled" =style ] when ]
|
||||||
|
tri add ;
|
||||||
|
|
||||||
|
: add-cfg-edges ( graph bb -- graph' )
|
||||||
|
dup successors>> [
|
||||||
|
[ number>> ] bi@ ->
|
||||||
|
] with each ;
|
||||||
|
|
||||||
|
SYMBOL: linearize?
|
||||||
|
linearize? off
|
||||||
|
|
||||||
|
: ?linearize ( graph cfg -- graph' )
|
||||||
|
linearize? get [
|
||||||
|
<anon>
|
||||||
|
edge[ "invis" =style ];
|
||||||
|
swap linearization-order [ number>> ] map ~->
|
||||||
|
add
|
||||||
|
] [ drop ] if ;
|
||||||
|
|
||||||
|
SYMBOL: step
|
||||||
|
|
||||||
|
: (cfgviz) ( cfg label filename -- )
|
||||||
|
[
|
||||||
|
<digraph>
|
||||||
|
graph[ "t" =labelloc ];
|
||||||
|
node[ "box" =shape "Courier" =fontname 10 =fontsize ];
|
||||||
|
swap drop ! =label
|
||||||
|
swap
|
||||||
|
[ ?linearize ]
|
||||||
|
[ [ add-cfg-vertex ] each-basic-block ]
|
||||||
|
[ [ add-cfg-edges ] each-basic-block ]
|
||||||
|
tri
|
||||||
|
] dip png ;
|
||||||
|
|
||||||
|
: cfgviz ( cfg pass -- )
|
||||||
|
"After " prepend
|
||||||
|
step inc step get number>string
|
||||||
|
(cfgviz) ;
|
||||||
|
|
||||||
|
: (watch-cfgs) ( cfg -- )
|
||||||
|
0 step [
|
||||||
|
[
|
||||||
|
dup "build-cfg" cfgviz
|
||||||
|
dup \ optimize-cfg def>> [
|
||||||
|
[ def>> call( cfg -- cfg' ) ] keep
|
||||||
|
name>> cfgviz
|
||||||
|
] with each
|
||||||
|
finalize-cfg "finalize-cfg" cfgviz
|
||||||
|
] with-cfg
|
||||||
|
] with-variable ;
|
||||||
|
|
||||||
|
: watch-cfgs ( quot -- )
|
||||||
|
test-builder [ (watch-cfgs) ] each ;
|
||||||
Binary file not shown.
|
After Width: | Height: | Size: 30 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 31 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 19 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 18 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 19 KiB |
|
|
@ -0,0 +1,131 @@
|
||||||
|
! Copyright (C) 2010 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors combinators combinators.short-circuit fry
|
||||||
|
kernel make math sequences
|
||||||
|
cpu.architecture
|
||||||
|
compiler.cfg.hats
|
||||||
|
compiler.cfg.utilities
|
||||||
|
compiler.cfg.registers
|
||||||
|
compiler.cfg.instructions
|
||||||
|
compiler.cfg.gvn.math
|
||||||
|
compiler.cfg.gvn.graph
|
||||||
|
compiler.cfg.gvn.rewrite ;
|
||||||
|
IN: compiler.cfg.gvn.alien
|
||||||
|
|
||||||
|
M: ##box-displaced-alien rewrite
|
||||||
|
dup displacement>> vreg>insn zero-insn?
|
||||||
|
[ [ dst>> ] [ base>> ] bi <copy> ] [ drop f ] if ;
|
||||||
|
|
||||||
|
! ##box-displaced-alien f 1 2 3 <class>
|
||||||
|
! ##unbox-c-ptr 4 1 <class>
|
||||||
|
! =>
|
||||||
|
! ##box-displaced-alien f 1 2 3 <class>
|
||||||
|
! ##unbox-c-ptr 5 3 <class>
|
||||||
|
! ##add 4 5 2
|
||||||
|
|
||||||
|
: rewrite-unbox-alien ( insn box-insn -- insn )
|
||||||
|
[ dst>> ] [ src>> ] bi* <copy> ;
|
||||||
|
|
||||||
|
: rewrite-unbox-displaced-alien ( insn box-insn -- insns )
|
||||||
|
[
|
||||||
|
[ dst>> ]
|
||||||
|
[ [ base>> ] [ base-class>> ] [ displacement>> ] tri ] bi*
|
||||||
|
[ ^^unbox-c-ptr ] dip
|
||||||
|
##add
|
||||||
|
] { } make ;
|
||||||
|
|
||||||
|
: rewrite-unbox-any-c-ptr ( insn -- insn/f )
|
||||||
|
dup src>> vreg>insn
|
||||||
|
{
|
||||||
|
{ [ dup ##box-alien? ] [ rewrite-unbox-alien ] }
|
||||||
|
{ [ dup ##box-displaced-alien? ] [ rewrite-unbox-displaced-alien ] }
|
||||||
|
[ 2drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##unbox-any-c-ptr rewrite rewrite-unbox-any-c-ptr ;
|
||||||
|
|
||||||
|
M: ##unbox-alien rewrite rewrite-unbox-any-c-ptr ;
|
||||||
|
|
||||||
|
! Fuse ##add-imm into ##load-memory(-imm) and ##store-memory(-imm)
|
||||||
|
! just update the offset in the instruction
|
||||||
|
: fuse-base-offset? ( insn -- ? )
|
||||||
|
base>> vreg>insn ##add-imm? ;
|
||||||
|
|
||||||
|
: fuse-base-offset ( insn -- insn' )
|
||||||
|
dup base>> vreg>insn
|
||||||
|
[ src1>> ] [ src2>> ] bi
|
||||||
|
[ >>base ] [ '[ _ + ] change-offset ] bi* ;
|
||||||
|
|
||||||
|
! Fuse ##add-imm into ##load-memory and ##store-memory
|
||||||
|
! just update the offset in the instruction
|
||||||
|
: fuse-displacement-offset? ( insn -- ? )
|
||||||
|
{ [ scale>> 0 = ] [ displacement>> vreg>insn ##add-imm? ] } 1&& ;
|
||||||
|
|
||||||
|
: fuse-displacement-offset ( insn -- insn' )
|
||||||
|
dup displacement>> vreg>insn
|
||||||
|
[ src1>> ] [ src2>> ] bi
|
||||||
|
[ >>displacement ] [ '[ _ + ] change-offset ] bi* ;
|
||||||
|
|
||||||
|
! Fuse ##add into ##load-memory-imm and ##store-memory-imm
|
||||||
|
! construct a new ##load-memory or ##store-memory with the
|
||||||
|
! ##add's operand as the displacement
|
||||||
|
: fuse-displacement? ( insn -- ? )
|
||||||
|
{
|
||||||
|
[ offset>> 0 = complex-addressing? or ]
|
||||||
|
[ base>> vreg>insn ##add? ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
GENERIC: alien-insn-value ( insn -- value )
|
||||||
|
|
||||||
|
M: ##load-memory-imm alien-insn-value dst>> ;
|
||||||
|
M: ##store-memory-imm alien-insn-value src>> ;
|
||||||
|
|
||||||
|
GENERIC: new-alien-insn ( value base displacement scale offset rep c-type insn -- insn )
|
||||||
|
|
||||||
|
M: ##load-memory-imm new-alien-insn drop \ ##load-memory new-insn ;
|
||||||
|
M: ##store-memory-imm new-alien-insn drop \ ##store-memory new-insn ;
|
||||||
|
|
||||||
|
: fuse-displacement ( insn -- insn' )
|
||||||
|
{
|
||||||
|
[ alien-insn-value ]
|
||||||
|
[ base>> vreg>insn [ src1>> ] [ src2>> ] bi ]
|
||||||
|
[ drop 0 ]
|
||||||
|
[ offset>> ]
|
||||||
|
[ rep>> ]
|
||||||
|
[ c-type>> ]
|
||||||
|
[ ]
|
||||||
|
} cleave new-alien-insn ;
|
||||||
|
|
||||||
|
! Fuse ##shl-imm into ##load-memory or ##store-memory
|
||||||
|
: scale-insn? ( insn -- ? )
|
||||||
|
{ [ ##shl-imm? ] [ src2>> { 1 2 3 } member? ] } 1&& ;
|
||||||
|
|
||||||
|
: fuse-scale? ( insn -- ? )
|
||||||
|
{ [ scale>> 0 = ] [ displacement>> vreg>insn scale-insn? ] } 1&& ;
|
||||||
|
|
||||||
|
: fuse-scale ( insn -- insn' )
|
||||||
|
dup displacement>> vreg>insn
|
||||||
|
[ src1>> ] [ src2>> ] bi
|
||||||
|
[ >>displacement ] [ >>scale ] bi* ;
|
||||||
|
|
||||||
|
: rewrite-memory-op ( insn -- insn/f )
|
||||||
|
complex-addressing? [
|
||||||
|
{
|
||||||
|
{ [ dup fuse-base-offset? ] [ fuse-base-offset ] }
|
||||||
|
{ [ dup fuse-displacement-offset? ] [ fuse-displacement-offset ] }
|
||||||
|
{ [ dup fuse-scale? ] [ fuse-scale ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond
|
||||||
|
] [ drop f ] if ;
|
||||||
|
|
||||||
|
: rewrite-memory-imm-op ( insn -- insn/f )
|
||||||
|
{
|
||||||
|
{ [ dup fuse-base-offset? ] [ fuse-base-offset ] }
|
||||||
|
{ [ dup fuse-displacement? ] [ fuse-displacement ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##load-memory rewrite rewrite-memory-op ;
|
||||||
|
M: ##load-memory-imm rewrite rewrite-memory-imm-op ;
|
||||||
|
M: ##store-memory rewrite rewrite-memory-op ;
|
||||||
|
M: ##store-memory-imm rewrite rewrite-memory-imm-op ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,316 @@
|
||||||
|
! Copyright (C) 2010 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors combinators kernel math math.order namespaces
|
||||||
|
sequences vectors combinators.short-circuit
|
||||||
|
cpu.architecture
|
||||||
|
compiler.cfg
|
||||||
|
compiler.cfg.comparisons
|
||||||
|
compiler.cfg.instructions
|
||||||
|
compiler.cfg.registers
|
||||||
|
compiler.cfg.gvn.math
|
||||||
|
compiler.cfg.gvn.graph
|
||||||
|
compiler.cfg.gvn.rewrite ;
|
||||||
|
IN: compiler.cfg.gvn.comparisons
|
||||||
|
|
||||||
|
! Optimizations performed here:
|
||||||
|
!
|
||||||
|
! 1) Eliminating intermediate boolean values when the result of
|
||||||
|
! a comparison is used by a compare-branch
|
||||||
|
! 2) Folding comparisons where both inputs are literal
|
||||||
|
! 3) Folding comparisons where both inputs are congruent
|
||||||
|
! 4) Converting compare instructions into compare-imm instructions
|
||||||
|
|
||||||
|
: fold-compare-imm? ( insn -- ? )
|
||||||
|
src1>> vreg>insn literal-insn? ;
|
||||||
|
|
||||||
|
: evaluate-compare-imm ( insn -- ? )
|
||||||
|
[ src1>> vreg>literal ] [ src2>> ] [ cc>> ] tri
|
||||||
|
{
|
||||||
|
{ cc= [ eq? ] }
|
||||||
|
{ cc/= [ eq? not ] }
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
: fold-compare-integer-imm? ( insn -- ? )
|
||||||
|
src1>> vreg>insn ##load-integer? ;
|
||||||
|
|
||||||
|
: evaluate-compare-integer-imm ( insn -- ? )
|
||||||
|
[ src1>> vreg>integer ] [ src2>> ] [ cc>> ] tri
|
||||||
|
[ <=> ] dip evaluate-cc ;
|
||||||
|
|
||||||
|
: fold-test-imm? ( insn -- ? )
|
||||||
|
src1>> vreg>insn ##load-integer? ;
|
||||||
|
|
||||||
|
: evaluate-test-imm ( insn -- ? )
|
||||||
|
[ src1>> vreg>integer ] [ src2>> ] [ cc>> ] tri
|
||||||
|
[ bitand ] dip {
|
||||||
|
{ cc= [ 0 = ] }
|
||||||
|
{ cc/= [ 0 = not ] }
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
: rewrite-into-test? ( insn -- ? )
|
||||||
|
{
|
||||||
|
[ drop test-instruction? ]
|
||||||
|
[ cc>> { cc= cc/= } member-eq? ]
|
||||||
|
[ src2>> 0 = ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
: >compare< ( insn -- in1 in2 cc )
|
||||||
|
[ src1>> ] [ src2>> ] [ cc>> ] tri ; inline
|
||||||
|
|
||||||
|
: >test-vector< ( insn -- src1 temp rep vcc )
|
||||||
|
{
|
||||||
|
[ src1>> ]
|
||||||
|
[ drop next-vreg ]
|
||||||
|
[ rep>> ]
|
||||||
|
[ vcc>> ]
|
||||||
|
} cleave ; inline
|
||||||
|
|
||||||
|
UNION: scalar-compare-insn
|
||||||
|
##compare
|
||||||
|
##compare-imm
|
||||||
|
##compare-integer
|
||||||
|
##compare-integer-imm
|
||||||
|
##test
|
||||||
|
##test-imm
|
||||||
|
##compare-float-unordered
|
||||||
|
##compare-float-ordered ;
|
||||||
|
|
||||||
|
UNION: general-compare-insn scalar-compare-insn ##test-vector ;
|
||||||
|
|
||||||
|
: rewrite-boolean-comparison? ( insn -- ? )
|
||||||
|
{
|
||||||
|
[ src1>> vreg>insn general-compare-insn? ]
|
||||||
|
[ src2>> not ]
|
||||||
|
[ cc>> cc/= eq? ]
|
||||||
|
} 1&& ; inline
|
||||||
|
|
||||||
|
: rewrite-boolean-comparison ( insn -- insn )
|
||||||
|
src1>> vreg>insn {
|
||||||
|
{ [ dup ##compare? ] [ >compare< \ ##compare-branch new-insn ] }
|
||||||
|
{ [ dup ##compare-imm? ] [ >compare< \ ##compare-imm-branch new-insn ] }
|
||||||
|
{ [ dup ##compare-integer? ] [ >compare< \ ##compare-integer-branch new-insn ] }
|
||||||
|
{ [ dup ##compare-integer-imm? ] [ >compare< \ ##compare-integer-imm-branch new-insn ] }
|
||||||
|
{ [ dup ##test? ] [ >compare< \ ##test-branch new-insn ] }
|
||||||
|
{ [ dup ##test-imm? ] [ >compare< \ ##test-imm-branch new-insn ] }
|
||||||
|
{ [ dup ##compare-float-unordered? ] [ >compare< \ ##compare-float-unordered-branch new-insn ] }
|
||||||
|
{ [ dup ##compare-float-ordered? ] [ >compare< \ ##compare-float-ordered-branch new-insn ] }
|
||||||
|
{ [ dup ##test-vector? ] [ >test-vector< \ ##test-vector-branch new-insn ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: fold-branch ( ? -- insn )
|
||||||
|
0 1 ?
|
||||||
|
basic-block get [ nth 1vector ] change-successors drop
|
||||||
|
\ ##branch new-insn ;
|
||||||
|
|
||||||
|
: fold-compare-imm-branch ( insn -- insn/f )
|
||||||
|
evaluate-compare-imm fold-branch ;
|
||||||
|
|
||||||
|
: >test-branch ( insn -- insn )
|
||||||
|
[ src1>> ] [ src1>> ] [ cc>> ] tri \ ##test-branch new-insn ;
|
||||||
|
|
||||||
|
M: ##compare-imm-branch rewrite
|
||||||
|
{
|
||||||
|
{ [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
|
||||||
|
{ [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: fold-compare-integer-imm-branch ( insn -- insn/f )
|
||||||
|
evaluate-compare-integer-imm fold-branch ;
|
||||||
|
|
||||||
|
M: ##compare-integer-imm-branch rewrite
|
||||||
|
{
|
||||||
|
{ [ dup fold-compare-integer-imm? ] [ fold-compare-integer-imm-branch ] }
|
||||||
|
{ [ dup rewrite-into-test? ] [ >test-branch ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: fold-test-imm-branch ( insn -- insn/f )
|
||||||
|
evaluate-test-imm fold-branch ;
|
||||||
|
|
||||||
|
M: ##test-imm-branch rewrite
|
||||||
|
{
|
||||||
|
{ [ dup fold-test-imm? ] [ fold-test-imm-branch ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
|
||||||
|
[ [ swap ] dip swap-cc ] when ; inline
|
||||||
|
|
||||||
|
: (>compare-imm-branch) ( insn swap? -- src1 src2 cc )
|
||||||
|
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] dip swap-compare ; inline
|
||||||
|
|
||||||
|
: >compare-imm-branch ( insn swap? -- insn' )
|
||||||
|
(>compare-imm-branch)
|
||||||
|
[ vreg>literal ] dip
|
||||||
|
\ ##compare-imm-branch new-insn ; inline
|
||||||
|
|
||||||
|
: >compare-integer-imm-branch ( insn swap? -- insn' )
|
||||||
|
(>compare-imm-branch)
|
||||||
|
[ vreg>integer ] dip
|
||||||
|
\ ##compare-integer-imm-branch new-insn ; inline
|
||||||
|
|
||||||
|
: evaluate-self-compare ( insn -- ? )
|
||||||
|
cc>> { cc= cc<= cc>= } member-eq? ;
|
||||||
|
|
||||||
|
: rewrite-self-compare-branch ( insn -- insn' )
|
||||||
|
evaluate-self-compare fold-branch ;
|
||||||
|
|
||||||
|
M: ##compare-branch rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm-branch ] }
|
||||||
|
{ [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm-branch ] }
|
||||||
|
{ [ dup diagonal? ] [ rewrite-self-compare-branch ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##compare-integer-branch rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-integer-imm-branch ] }
|
||||||
|
{ [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-integer-imm-branch ] }
|
||||||
|
{ [ dup diagonal? ] [ rewrite-self-compare-branch ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: (>compare-imm) ( insn swap? -- dst src1 src2 cc )
|
||||||
|
[ { [ dst>> ] [ src1>> ] [ src2>> ] [ cc>> ] } cleave ] dip
|
||||||
|
swap-compare ; inline
|
||||||
|
|
||||||
|
: >compare-imm ( insn swap? -- insn' )
|
||||||
|
(>compare-imm)
|
||||||
|
[ vreg>literal ] dip
|
||||||
|
next-vreg \ ##compare-imm new-insn ; inline
|
||||||
|
|
||||||
|
: >compare-integer-imm ( insn swap? -- insn' )
|
||||||
|
(>compare-imm)
|
||||||
|
[ vreg>integer ] dip
|
||||||
|
next-vreg \ ##compare-integer-imm new-insn ; inline
|
||||||
|
|
||||||
|
: >boolean-insn ( insn ? -- insn' )
|
||||||
|
[ dst>> ] dip \ ##load-reference new-insn ;
|
||||||
|
|
||||||
|
: rewrite-self-compare ( insn -- insn' )
|
||||||
|
dup evaluate-self-compare >boolean-insn ;
|
||||||
|
|
||||||
|
M: ##compare rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm ] }
|
||||||
|
{ [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm ] }
|
||||||
|
{ [ dup diagonal? ] [ rewrite-self-compare ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##compare-integer rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-integer-imm ] }
|
||||||
|
{ [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-integer-imm ] }
|
||||||
|
{ [ dup diagonal? ] [ rewrite-self-compare ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: rewrite-redundant-comparison? ( insn -- ? )
|
||||||
|
{
|
||||||
|
[ src1>> vreg>insn scalar-compare-insn? ]
|
||||||
|
[ src2>> not ]
|
||||||
|
[ cc>> { cc= cc/= } member? ]
|
||||||
|
} 1&& ; inline
|
||||||
|
|
||||||
|
: rewrite-redundant-comparison ( insn -- insn' )
|
||||||
|
[ cc>> ] [ dst>> ] [ src1>> vreg>insn ] tri {
|
||||||
|
{ [ dup ##compare? ] [ >compare< next-vreg \ ##compare new-insn ] }
|
||||||
|
{ [ dup ##compare-imm? ] [ >compare< next-vreg \ ##compare-imm new-insn ] }
|
||||||
|
{ [ dup ##compare-integer? ] [ >compare< next-vreg \ ##compare-integer new-insn ] }
|
||||||
|
{ [ dup ##compare-integer-imm? ] [ >compare< next-vreg \ ##compare-integer-imm new-insn ] }
|
||||||
|
{ [ dup ##test? ] [ >compare< next-vreg \ ##test new-insn ] }
|
||||||
|
{ [ dup ##test-imm? ] [ >compare< next-vreg \ ##test-imm new-insn ] }
|
||||||
|
{ [ dup ##compare-float-unordered? ] [ >compare< next-vreg \ ##compare-float-unordered new-insn ] }
|
||||||
|
{ [ dup ##compare-float-ordered? ] [ >compare< next-vreg \ ##compare-float-ordered new-insn ] }
|
||||||
|
} cond
|
||||||
|
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
|
||||||
|
|
||||||
|
: fold-compare-imm ( insn -- insn' )
|
||||||
|
dup evaluate-compare-imm >boolean-insn ;
|
||||||
|
|
||||||
|
M: ##compare-imm rewrite
|
||||||
|
{
|
||||||
|
{ [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
|
||||||
|
{ [ dup fold-compare-imm? ] [ fold-compare-imm ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: fold-compare-integer-imm ( insn -- insn' )
|
||||||
|
dup evaluate-compare-integer-imm >boolean-insn ;
|
||||||
|
|
||||||
|
: >test ( insn -- insn' )
|
||||||
|
{ [ dst>> ] [ src1>> ] [ src1>> ] [ cc>> ] [ temp>> ] } cleave
|
||||||
|
\ ##test new-insn ;
|
||||||
|
|
||||||
|
M: ##compare-integer-imm rewrite
|
||||||
|
{
|
||||||
|
{ [ dup fold-compare-integer-imm? ] [ fold-compare-integer-imm ] }
|
||||||
|
{ [ dup rewrite-into-test? ] [ >test ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: (simplify-test) ( insn -- src1 src2 cc )
|
||||||
|
[ src1>> vreg>insn [ src1>> ] [ src2>> ] bi ] [ cc>> ] bi ; inline
|
||||||
|
|
||||||
|
: simplify-test ( insn -- insn )
|
||||||
|
dup (simplify-test) drop [ >>src1 ] [ >>src2 ] bi* ; inline
|
||||||
|
|
||||||
|
: simplify-test-branch ( insn -- insn )
|
||||||
|
dup (simplify-test) drop [ >>src1 ] [ >>src2 ] bi* ; inline
|
||||||
|
|
||||||
|
: (simplify-test-imm) ( insn -- src1 src2 cc )
|
||||||
|
[ src1>> vreg>insn [ src1>> ] [ src2>> ] bi ] [ cc>> ] bi ; inline
|
||||||
|
|
||||||
|
: simplify-test-imm ( insn -- insn )
|
||||||
|
[ dst>> ] [ (simplify-test-imm) ] [ temp>> ] tri \ ##test-imm new-insn ; inline
|
||||||
|
|
||||||
|
: simplify-test-imm-branch ( insn -- insn )
|
||||||
|
(simplify-test-imm) \ ##test-imm-branch new-insn ; inline
|
||||||
|
|
||||||
|
: >test-imm ( insn ? -- insn' )
|
||||||
|
(>compare-imm) [ vreg>integer ] dip next-vreg
|
||||||
|
\ ##test-imm new-insn ; inline
|
||||||
|
|
||||||
|
: >test-imm-branch ( insn ? -- insn' )
|
||||||
|
(>compare-imm-branch) [ vreg>integer ] dip
|
||||||
|
\ ##test-imm-branch new-insn ; inline
|
||||||
|
|
||||||
|
M: ##test rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src1>> vreg-immediate-comparand? ] [ t >test-imm ] }
|
||||||
|
{ [ dup src2>> vreg-immediate-comparand? ] [ f >test-imm ] }
|
||||||
|
{ [ dup diagonal? ] [
|
||||||
|
{
|
||||||
|
{ [ dup src1>> vreg>insn ##and? ] [ simplify-test ] }
|
||||||
|
{ [ dup src1>> vreg>insn ##and-imm? ] [ simplify-test-imm ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond
|
||||||
|
] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##test-branch rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src1>> vreg-immediate-comparand? ] [ t >test-imm-branch ] }
|
||||||
|
{ [ dup src2>> vreg-immediate-comparand? ] [ f >test-imm-branch ] }
|
||||||
|
{ [ dup diagonal? ] [
|
||||||
|
{
|
||||||
|
{ [ dup src1>> vreg>insn ##and? ] [ simplify-test-branch ] }
|
||||||
|
{ [ dup src1>> vreg>insn ##and-imm? ] [ simplify-test-imm-branch ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond
|
||||||
|
] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: fold-test-imm ( insn -- insn' )
|
||||||
|
dup evaluate-test-imm >boolean-insn ;
|
||||||
|
|
||||||
|
M: ##test-imm rewrite
|
||||||
|
{
|
||||||
|
{ [ dup fold-test-imm? ] [ fold-test-imm ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
@ -0,0 +1,85 @@
|
||||||
|
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors arrays classes classes.algebra combinators fry
|
||||||
|
generic.parser kernel math namespaces quotations sequences slots
|
||||||
|
words make sets
|
||||||
|
compiler.cfg.instructions
|
||||||
|
compiler.cfg.instructions.syntax
|
||||||
|
compiler.cfg.gvn.graph ;
|
||||||
|
FROM: sequences.private => set-array-nth ;
|
||||||
|
IN: compiler.cfg.gvn.expressions
|
||||||
|
|
||||||
|
<<
|
||||||
|
|
||||||
|
GENERIC: >expr ( insn -- expr )
|
||||||
|
|
||||||
|
: input-values ( slot-specs -- slot-specs' )
|
||||||
|
[ type>> { use literal } member-eq? ] filter ;
|
||||||
|
|
||||||
|
: slot->expr-quot ( slot-spec -- quot )
|
||||||
|
[ name>> reader-word 1quotation ]
|
||||||
|
[
|
||||||
|
type>> {
|
||||||
|
{ use [ [ vreg>vn ] ] }
|
||||||
|
{ literal [ [ ] ] }
|
||||||
|
} case
|
||||||
|
] bi append ;
|
||||||
|
|
||||||
|
: narray-quot ( length -- quot )
|
||||||
|
[
|
||||||
|
[ , [ f <array> ] % ]
|
||||||
|
[
|
||||||
|
dup iota [
|
||||||
|
- 1 - , [ swap [ set-array-nth ] keep ] %
|
||||||
|
] with each
|
||||||
|
] bi
|
||||||
|
] [ ] make ;
|
||||||
|
|
||||||
|
: >expr-quot ( insn slot-specs -- quot )
|
||||||
|
[
|
||||||
|
[ literalize , \ swap , ]
|
||||||
|
[
|
||||||
|
[ [ slot->expr-quot ] map cleave>quot % ]
|
||||||
|
[ length 1 + narray-quot % ]
|
||||||
|
bi
|
||||||
|
] bi*
|
||||||
|
] [ ] make ;
|
||||||
|
|
||||||
|
: define->expr-method ( insn slot-specs -- )
|
||||||
|
[ drop \ >expr create-method-in ] [ >expr-quot ] 2bi define ;
|
||||||
|
|
||||||
|
insn-classes get
|
||||||
|
[ foldable-insn class<= ] filter
|
||||||
|
{ ##copy ##load-integer ##load-reference } diff
|
||||||
|
[
|
||||||
|
dup "insn-slots" word-prop input-values
|
||||||
|
define->expr-method
|
||||||
|
] each
|
||||||
|
|
||||||
|
>>
|
||||||
|
|
||||||
|
TUPLE: integer-expr value ;
|
||||||
|
|
||||||
|
C: <integer-expr> integer-expr
|
||||||
|
|
||||||
|
TUPLE: reference-expr value ;
|
||||||
|
|
||||||
|
C: <reference-expr> reference-expr
|
||||||
|
|
||||||
|
M: reference-expr equal?
|
||||||
|
over reference-expr? [
|
||||||
|
[ value>> ] bi@
|
||||||
|
2dup [ float? ] both?
|
||||||
|
[ fp-bitwise= ] [ eq? ] if
|
||||||
|
] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
M: reference-expr hashcode*
|
||||||
|
nip value>> dup float? [ double>bits ] [ identity-hashcode ] if ;
|
||||||
|
|
||||||
|
M: insn >expr drop input-expr-counter counter neg ;
|
||||||
|
|
||||||
|
M: ##copy >expr "Fail" throw ;
|
||||||
|
|
||||||
|
M: ##load-integer >expr val>> <integer-expr> ;
|
||||||
|
|
||||||
|
M: ##load-reference >expr obj>> <reference-expr> ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Value numbering expressions
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,39 @@
|
||||||
|
! Copyright (C) 2010 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors kernel layouts math math.bitwise
|
||||||
|
compiler.cfg.instructions
|
||||||
|
compiler.cfg.gvn.graph
|
||||||
|
compiler.cfg.gvn.rewrite ;
|
||||||
|
IN: compiler.cfg.gvn.folding
|
||||||
|
|
||||||
|
: binary-constant-fold? ( insn -- ? )
|
||||||
|
src1>> vreg>insn ##load-integer? ; inline
|
||||||
|
|
||||||
|
GENERIC: binary-constant-fold* ( x y insn -- z )
|
||||||
|
|
||||||
|
M: ##add-imm binary-constant-fold* drop + ;
|
||||||
|
M: ##sub-imm binary-constant-fold* drop - ;
|
||||||
|
M: ##mul-imm binary-constant-fold* drop * ;
|
||||||
|
M: ##and-imm binary-constant-fold* drop bitand ;
|
||||||
|
M: ##or-imm binary-constant-fold* drop bitor ;
|
||||||
|
M: ##xor-imm binary-constant-fold* drop bitxor ;
|
||||||
|
M: ##shr-imm binary-constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ;
|
||||||
|
M: ##sar-imm binary-constant-fold* drop neg shift ;
|
||||||
|
M: ##shl-imm binary-constant-fold* drop shift ;
|
||||||
|
|
||||||
|
: binary-constant-fold ( insn -- insn' )
|
||||||
|
[ dst>> ]
|
||||||
|
[ [ src1>> vreg>integer ] [ src2>> ] [ ] tri binary-constant-fold* ] bi
|
||||||
|
\ ##load-integer new-insn ; inline
|
||||||
|
|
||||||
|
: unary-constant-fold? ( insn -- ? )
|
||||||
|
src>> vreg>insn ##load-integer? ; inline
|
||||||
|
|
||||||
|
GENERIC: unary-constant-fold* ( x insn -- y )
|
||||||
|
|
||||||
|
M: ##not unary-constant-fold* drop bitnot ;
|
||||||
|
M: ##neg unary-constant-fold* drop neg ;
|
||||||
|
|
||||||
|
: unary-constant-fold ( insn -- insn' )
|
||||||
|
[ dst>> ] [ [ src>> vreg>integer ] [ ] bi unary-constant-fold* ] bi
|
||||||
|
\ ##load-integer new-insn ; inline
|
||||||
|
|
@ -0,0 +1,49 @@
|
||||||
|
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors kernel math namespaces assocs ;
|
||||||
|
IN: compiler.cfg.gvn.graph
|
||||||
|
|
||||||
|
SYMBOL: input-expr-counter
|
||||||
|
|
||||||
|
! assoc mapping vregs to value numbers
|
||||||
|
! this is the identity on canonical representatives
|
||||||
|
SYMBOL: vregs>vns
|
||||||
|
|
||||||
|
! assoc mapping expressions to value numbers
|
||||||
|
SYMBOL: exprs>vns
|
||||||
|
|
||||||
|
! assoc mapping value numbers to instructions
|
||||||
|
SYMBOL: vns>insns
|
||||||
|
|
||||||
|
! assoc mapping vregs to *global* value numbers
|
||||||
|
SYMBOL: vregs>gvns
|
||||||
|
|
||||||
|
SYMBOL: changed?
|
||||||
|
|
||||||
|
: vn>insn ( vn -- insn ) vns>insns get at ;
|
||||||
|
|
||||||
|
! : vreg>vn ( vreg -- vn ) vregs>vns get [ ] cache ;
|
||||||
|
|
||||||
|
: vreg>vn ( vreg -- vn ) vregs>gvns get at ;
|
||||||
|
|
||||||
|
! : set-vn ( vn vreg -- ) vregs>vns get set-at ;
|
||||||
|
|
||||||
|
: local-vn ( vn vreg -- lvn )
|
||||||
|
vregs>vns get ?at
|
||||||
|
[ nip ]
|
||||||
|
[ dupd vregs>vns get set-at ] if ;
|
||||||
|
|
||||||
|
: set-vn ( vn vreg -- )
|
||||||
|
[ local-vn ] keep
|
||||||
|
vregs>gvns get maybe-set-at [ changed? on ] when ;
|
||||||
|
|
||||||
|
: vreg>insn ( vreg -- insn ) vreg>vn vn>insn ;
|
||||||
|
|
||||||
|
: init-gvn ( -- )
|
||||||
|
H{ } clone vregs>gvns set ;
|
||||||
|
|
||||||
|
: init-value-graph ( -- )
|
||||||
|
0 input-expr-counter set
|
||||||
|
H{ } clone vregs>vns set
|
||||||
|
H{ } clone exprs>vns set
|
||||||
|
H{ } clone vns>insns set ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Value numbering expression graph
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,149 @@
|
||||||
|
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: namespaces arrays assocs kernel accessors fry grouping
|
||||||
|
sorting sets sequences locals
|
||||||
|
cpu.architecture
|
||||||
|
sequences.deep
|
||||||
|
compiler.cfg
|
||||||
|
compiler.cfg.rpo
|
||||||
|
compiler.cfg.def-use
|
||||||
|
compiler.cfg.utilities
|
||||||
|
compiler.cfg.instructions
|
||||||
|
compiler.cfg.gvn.alien
|
||||||
|
compiler.cfg.gvn.comparisons
|
||||||
|
compiler.cfg.gvn.graph
|
||||||
|
compiler.cfg.gvn.math
|
||||||
|
compiler.cfg.gvn.rewrite
|
||||||
|
compiler.cfg.gvn.slots
|
||||||
|
compiler.cfg.gvn.misc
|
||||||
|
compiler.cfg.gvn.expressions ;
|
||||||
|
IN: compiler.cfg.gvn
|
||||||
|
|
||||||
|
GENERIC: process-instruction ( insn -- insn' )
|
||||||
|
|
||||||
|
: redundant-instruction ( insn vn -- insn' )
|
||||||
|
[ dst>> ] dip [ swap set-vn ] [ <copy> ] 2bi ;
|
||||||
|
|
||||||
|
:: useful-instruction ( insn expr -- insn' )
|
||||||
|
insn dst>> :> vn
|
||||||
|
vn vn set-vn
|
||||||
|
vn expr exprs>vns get set-at
|
||||||
|
insn vn vns>insns get set-at
|
||||||
|
insn ;
|
||||||
|
|
||||||
|
: check-redundancy ( insn -- insn' )
|
||||||
|
dup >expr dup exprs>vns get at
|
||||||
|
[ redundant-instruction ] [ useful-instruction ] ?if ;
|
||||||
|
|
||||||
|
M: insn process-instruction
|
||||||
|
dup rewrite [ process-instruction ] [ ] ?if ;
|
||||||
|
|
||||||
|
M: foldable-insn process-instruction
|
||||||
|
dup rewrite
|
||||||
|
[ process-instruction ]
|
||||||
|
[ dup defs-vregs length 1 = [ check-redundancy ] when ] ?if ;
|
||||||
|
|
||||||
|
M: ##copy process-instruction
|
||||||
|
dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ;
|
||||||
|
|
||||||
|
M: ##phi rewrite
|
||||||
|
[ dst>> ] [ inputs>> values [ vreg>vn ] map ] bi
|
||||||
|
dup sift
|
||||||
|
dup all-equal? [
|
||||||
|
nip
|
||||||
|
[ drop f ]
|
||||||
|
[ first <copy> ] if-empty
|
||||||
|
] [ 3drop f ] if ;
|
||||||
|
|
||||||
|
M: ##phi process-instruction
|
||||||
|
dup rewrite
|
||||||
|
[ process-instruction ] [ check-redundancy ] ?if ;
|
||||||
|
|
||||||
|
M: ##phi >expr
|
||||||
|
inputs>> values [ vreg>vn ] map \ ##phi prefix ;
|
||||||
|
|
||||||
|
M: array process-instruction
|
||||||
|
[ process-instruction ] map ;
|
||||||
|
|
||||||
|
: value-numbering-step ( insns -- insns' )
|
||||||
|
init-value-graph
|
||||||
|
! [ process-instruction ] map flatten ;
|
||||||
|
|
||||||
|
! idea: let rewrite do the constant/copy propagation (as
|
||||||
|
! that eventually leads to better VNs), but don't actually
|
||||||
|
! use them here, since changing the CFG mid-optimistic-GVN
|
||||||
|
! won't be sound
|
||||||
|
dup [ process-instruction drop ] each ;
|
||||||
|
|
||||||
|
: value-numbering ( cfg -- cfg )
|
||||||
|
dup
|
||||||
|
init-gvn
|
||||||
|
'[
|
||||||
|
changed? off
|
||||||
|
_ [ value-numbering-step ] simple-optimization
|
||||||
|
changed? get
|
||||||
|
] loop
|
||||||
|
|
||||||
|
dup [ init-value-graph [ process-instruction ] map flatten ] simple-optimization
|
||||||
|
cfg-changed predecessors-changed ;
|
||||||
|
|
||||||
|
USING: io math math.private prettyprint tools.annotations
|
||||||
|
compiler.cfg.debugger
|
||||||
|
compiler.cfg.graphviz
|
||||||
|
compiler.cfg.tco
|
||||||
|
compiler.cfg.useless-conditionals
|
||||||
|
compiler.cfg.branch-splitting
|
||||||
|
compiler.cfg.block-joining
|
||||||
|
compiler.cfg.height
|
||||||
|
compiler.cfg.ssa.construction
|
||||||
|
compiler.cfg.alias-analysis
|
||||||
|
compiler.cfg.copy-prop
|
||||||
|
compiler.cfg.dce
|
||||||
|
compiler.cfg.finalization ;
|
||||||
|
|
||||||
|
SYMBOL: gvn-test
|
||||||
|
|
||||||
|
[ 0 100 [ 1 fixnum+fast ] times ]
|
||||||
|
test-builder first [
|
||||||
|
optimize-tail-calls
|
||||||
|
delete-useless-conditionals
|
||||||
|
split-branches
|
||||||
|
join-blocks
|
||||||
|
normalize-height
|
||||||
|
construct-ssa
|
||||||
|
alias-analysis
|
||||||
|
] with-cfg gvn-test set-global
|
||||||
|
|
||||||
|
: watch-gvn ( -- )
|
||||||
|
\ value-numbering-step
|
||||||
|
[
|
||||||
|
'[
|
||||||
|
_ call
|
||||||
|
"Basic block #" write basic-block get number>> .
|
||||||
|
"vregs>gvns: " write vregs>gvns get .
|
||||||
|
"vregs>vns: " write vregs>vns get .
|
||||||
|
"exprs>vns: " write exprs>vns get .
|
||||||
|
"vns>insns: " write vns>insns get .
|
||||||
|
"\n---\n" print
|
||||||
|
]
|
||||||
|
] annotate ;
|
||||||
|
|
||||||
|
: reset-gvn ( -- )
|
||||||
|
\ value-numbering-step reset ;
|
||||||
|
|
||||||
|
: test-gvn ( -- )
|
||||||
|
watch-gvn
|
||||||
|
gvn-test get-global [
|
||||||
|
dup "Before GVN" "1" (cfgviz)
|
||||||
|
value-numbering
|
||||||
|
dup "After GVN" "2" (cfgviz)
|
||||||
|
copy-propagation
|
||||||
|
dup "After CP" "3" (cfgviz)
|
||||||
|
eliminate-dead-code
|
||||||
|
dup "After DCE" "4" (cfgviz)
|
||||||
|
finalize-cfg
|
||||||
|
dup "Final CFG" "5" (cfgviz)
|
||||||
|
drop
|
||||||
|
] with-cfg
|
||||||
|
reset-gvn ;
|
||||||
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,287 @@
|
||||||
|
! Copyright (C) 2010 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors combinators combinators.short-circuit
|
||||||
|
cpu.architecture fry kernel layouts locals make math sequences
|
||||||
|
compiler.cfg.instructions
|
||||||
|
compiler.cfg.registers
|
||||||
|
compiler.cfg.utilities
|
||||||
|
compiler.cfg.gvn.folding
|
||||||
|
compiler.cfg.gvn.graph
|
||||||
|
compiler.cfg.gvn.rewrite ;
|
||||||
|
IN: compiler.cfg.gvn.math
|
||||||
|
|
||||||
|
: f-insn? ( insn -- ? )
|
||||||
|
{ [ ##load-reference? ] [ obj>> not ] } 1&& ; inline
|
||||||
|
|
||||||
|
: zero-insn? ( insn -- ? )
|
||||||
|
{ [ ##load-integer? ] [ val>> 0 = ] } 1&& ; inline
|
||||||
|
|
||||||
|
M: ##tagged>integer rewrite
|
||||||
|
[ dst>> ] [ src>> vreg>insn ] bi {
|
||||||
|
{ [ dup ##load-integer? ] [ val>> tag-fixnum \ ##load-integer new-insn ] }
|
||||||
|
{ [ dup f-insn? ] [ drop \ f type-number \ ##load-integer new-insn ] }
|
||||||
|
[ 2drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: self-inverse ( insn -- insn' )
|
||||||
|
[ dst>> ] [ src>> vreg>insn src>> ] bi <copy> ;
|
||||||
|
|
||||||
|
: identity ( insn -- insn' )
|
||||||
|
[ dst>> ] [ src1>> ] bi <copy> ;
|
||||||
|
|
||||||
|
M: ##neg rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src>> vreg>insn ##neg? ] [ self-inverse ] }
|
||||||
|
{ [ dup unary-constant-fold? ] [ unary-constant-fold ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##not rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src>> vreg>insn ##not? ] [ self-inverse ] }
|
||||||
|
{ [ dup unary-constant-fold? ] [ unary-constant-fold ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
! Reassociation converts
|
||||||
|
! ## *-imm 2 1 X
|
||||||
|
! ## *-imm 3 2 Y
|
||||||
|
! into
|
||||||
|
! ## *-imm 3 1 (X $ Y)
|
||||||
|
! If * is associative, then $ is the same operation as *.
|
||||||
|
! In the case of shifts, $ is addition.
|
||||||
|
: (reassociate) ( insn -- dst src1 src2' src2'' )
|
||||||
|
{
|
||||||
|
[ dst>> ]
|
||||||
|
[ src1>> vreg>insn [ src1>> ] [ src2>> ] bi ]
|
||||||
|
[ src2>> ]
|
||||||
|
} cleave ; inline
|
||||||
|
|
||||||
|
: reassociate ( insn -- dst src1 src2 )
|
||||||
|
[ (reassociate) ] keep binary-constant-fold* ;
|
||||||
|
|
||||||
|
: ?new-insn ( dst src1 src2 ? class -- insn/f )
|
||||||
|
'[ _ new-insn ] [ 3drop f ] if ; inline
|
||||||
|
|
||||||
|
: reassociate-arithmetic ( insn new-insn -- insn/f )
|
||||||
|
[ reassociate dup immediate-arithmetic? ] dip ?new-insn ; inline
|
||||||
|
|
||||||
|
: reassociate-bitwise ( insn new-insn -- insn/f )
|
||||||
|
[ reassociate dup immediate-bitwise? ] dip ?new-insn ; inline
|
||||||
|
|
||||||
|
: reassociate-shift ( insn new-insn -- insn/f )
|
||||||
|
[ (reassociate) + dup immediate-shift-count? ] dip ?new-insn ; inline
|
||||||
|
|
||||||
|
M: ##add-imm rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src2>> 0 = ] [ identity ] }
|
||||||
|
{ [ dup binary-constant-fold? ] [ binary-constant-fold ] }
|
||||||
|
{ [ dup src1>> vreg>insn ##add-imm? ] [ \ ##add-imm reassociate-arithmetic ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: sub-imm>add-imm ( insn -- insn' )
|
||||||
|
[ dst>> ] [ src1>> ] [ src2>> neg ] tri
|
||||||
|
dup immediate-arithmetic?
|
||||||
|
\ ##add-imm ?new-insn ;
|
||||||
|
|
||||||
|
M: ##sub-imm rewrite sub-imm>add-imm ;
|
||||||
|
|
||||||
|
! Convert ##mul-imm -1 => ##neg
|
||||||
|
: mul-to-neg? ( insn -- ? )
|
||||||
|
src2>> -1 = ;
|
||||||
|
|
||||||
|
: mul-to-neg ( insn -- insn' )
|
||||||
|
[ dst>> ] [ src1>> ] bi \ ##neg new-insn ;
|
||||||
|
|
||||||
|
! Convert ##mul-imm 2^X => ##shl-imm X
|
||||||
|
: mul-to-shl? ( insn -- ? )
|
||||||
|
src2>> power-of-2? ;
|
||||||
|
|
||||||
|
: mul-to-shl ( insn -- insn' )
|
||||||
|
[ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
|
||||||
|
|
||||||
|
! Distribution converts
|
||||||
|
! ##+-imm 2 1 X
|
||||||
|
! ##*-imm 3 2 Y
|
||||||
|
! Into
|
||||||
|
! ##*-imm 4 1 Y
|
||||||
|
! ##+-imm 3 4 X*Y
|
||||||
|
! Where * is mul or shl, + is add or sub
|
||||||
|
! Have to make sure that X*Y fits in an immediate
|
||||||
|
:: (distribute) ( outer inner imm temp add-op mul-op -- new-outers/f )
|
||||||
|
imm immediate-arithmetic? [
|
||||||
|
[
|
||||||
|
temp inner src1>> outer src2>> mul-op execute
|
||||||
|
outer dst>> temp imm add-op execute
|
||||||
|
] { } make
|
||||||
|
] [ f ] if ; inline
|
||||||
|
|
||||||
|
: distribute-over-add? ( insn -- ? )
|
||||||
|
src1>> vreg>insn ##add-imm? ;
|
||||||
|
|
||||||
|
: distribute-over-sub? ( insn -- ? )
|
||||||
|
src1>> vreg>insn ##sub-imm? ;
|
||||||
|
|
||||||
|
: distribute ( insn add-op mul-op -- new-insns/f )
|
||||||
|
[
|
||||||
|
dup src1>> vreg>insn
|
||||||
|
2dup src2>> swap [ src2>> ] keep binary-constant-fold*
|
||||||
|
next-vreg
|
||||||
|
] 2dip (distribute) ; inline
|
||||||
|
|
||||||
|
M: ##mul-imm rewrite
|
||||||
|
{
|
||||||
|
{ [ dup binary-constant-fold? ] [ binary-constant-fold ] }
|
||||||
|
{ [ dup mul-to-neg? ] [ mul-to-neg ] }
|
||||||
|
{ [ dup mul-to-shl? ] [ mul-to-shl ] }
|
||||||
|
{ [ dup src1>> vreg>insn ##mul-imm? ] [ \ ##mul-imm reassociate-arithmetic ] }
|
||||||
|
{ [ dup distribute-over-add? ] [ \ ##add-imm \ ##mul-imm distribute ] }
|
||||||
|
{ [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##mul-imm distribute ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##and-imm rewrite
|
||||||
|
{
|
||||||
|
{ [ dup binary-constant-fold? ] [ binary-constant-fold ] }
|
||||||
|
{ [ dup src1>> vreg>insn ##and-imm? ] [ \ ##and-imm reassociate-bitwise ] }
|
||||||
|
{ [ dup src2>> 0 = ] [ dst>> 0 \ ##load-integer new-insn ] }
|
||||||
|
{ [ dup src2>> -1 = ] [ identity ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##or-imm rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src2>> 0 = ] [ identity ] }
|
||||||
|
{ [ dup src2>> -1 = ] [ dst>> -1 \ ##load-integer new-insn ] }
|
||||||
|
{ [ dup binary-constant-fold? ] [ binary-constant-fold ] }
|
||||||
|
{ [ dup src1>> vreg>insn ##or-imm? ] [ \ ##or-imm reassociate-bitwise ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##xor-imm rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src2>> 0 = ] [ identity ] }
|
||||||
|
{ [ dup src2>> -1 = ] [ [ dst>> ] [ src1>> ] bi \ ##not new-insn ] }
|
||||||
|
{ [ dup binary-constant-fold? ] [ binary-constant-fold ] }
|
||||||
|
{ [ dup src1>> vreg>insn ##xor-imm? ] [ \ ##xor-imm reassociate-bitwise ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##shl-imm rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src2>> 0 = ] [ identity ] }
|
||||||
|
{ [ dup binary-constant-fold? ] [ binary-constant-fold ] }
|
||||||
|
{ [ dup src1>> vreg>insn ##shl-imm? ] [ \ ##shl-imm reassociate-shift ] }
|
||||||
|
{ [ dup distribute-over-add? ] [ \ ##add-imm \ ##shl-imm distribute ] }
|
||||||
|
{ [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##shl-imm distribute ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##shr-imm rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src2>> 0 = ] [ identity ] }
|
||||||
|
{ [ dup binary-constant-fold? ] [ binary-constant-fold ] }
|
||||||
|
{ [ dup src1>> vreg>insn ##shr-imm? ] [ \ ##shr-imm reassociate-shift ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##sar-imm rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src2>> 0 = ] [ identity ] }
|
||||||
|
{ [ dup binary-constant-fold? ] [ binary-constant-fold ] }
|
||||||
|
{ [ dup src1>> vreg>insn ##sar-imm? ] [ \ ##sar-imm reassociate-shift ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
! Convert
|
||||||
|
! ##load-integer 2 X
|
||||||
|
! ##* 3 1 2
|
||||||
|
! Where * is an operation with an -imm equivalent into
|
||||||
|
! ##*-imm 3 1 X
|
||||||
|
: insn>imm-insn ( insn op swap? -- new-insn )
|
||||||
|
swap [
|
||||||
|
[ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
|
||||||
|
[ swap ] when vreg>integer
|
||||||
|
] dip new-insn ; inline
|
||||||
|
|
||||||
|
M: ##add rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##add-imm f insn>imm-insn ] }
|
||||||
|
{ [ dup src1>> vreg-immediate-arithmetic? ] [ \ ##add-imm t insn>imm-insn ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: diagonal? ( insn -- ? )
|
||||||
|
[ src1>> vreg>vn ] [ src2>> vreg>vn ] bi = ; inline
|
||||||
|
|
||||||
|
! ##sub 2 1 1 => ##load-integer 2 0
|
||||||
|
: rewrite-subtraction-identity ( insn -- insn' )
|
||||||
|
dst>> 0 \ ##load-integer new-insn ;
|
||||||
|
|
||||||
|
! ##load-integer 1 0
|
||||||
|
! ##sub 3 1 2
|
||||||
|
! =>
|
||||||
|
! ##neg 3 2
|
||||||
|
: sub-to-neg? ( ##sub -- ? )
|
||||||
|
src1>> vreg>insn zero-insn? ;
|
||||||
|
|
||||||
|
: sub-to-neg ( ##sub -- insn )
|
||||||
|
[ dst>> ] [ src2>> ] bi \ ##neg new-insn ;
|
||||||
|
|
||||||
|
M: ##sub rewrite
|
||||||
|
{
|
||||||
|
{ [ dup sub-to-neg? ] [ sub-to-neg ] }
|
||||||
|
{ [ dup diagonal? ] [ rewrite-subtraction-identity ] }
|
||||||
|
{ [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##sub-imm f insn>imm-insn ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##mul rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##mul-imm f insn>imm-insn ] }
|
||||||
|
{ [ dup src1>> vreg-immediate-arithmetic? ] [ \ ##mul-imm t insn>imm-insn ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##and rewrite
|
||||||
|
{
|
||||||
|
{ [ dup diagonal? ] [ identity ] }
|
||||||
|
{ [ dup src2>> vreg-immediate-bitwise? ] [ \ ##and-imm f insn>imm-insn ] }
|
||||||
|
{ [ dup src1>> vreg-immediate-bitwise? ] [ \ ##and-imm t insn>imm-insn ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##or rewrite
|
||||||
|
{
|
||||||
|
{ [ dup diagonal? ] [ identity ] }
|
||||||
|
{ [ dup src2>> vreg-immediate-bitwise? ] [ \ ##or-imm f insn>imm-insn ] }
|
||||||
|
{ [ dup src1>> vreg-immediate-bitwise? ] [ \ ##or-imm t insn>imm-insn ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##xor rewrite
|
||||||
|
{
|
||||||
|
{ [ dup diagonal? ] [ dst>> 0 \ ##load-integer new-insn ] }
|
||||||
|
{ [ dup src2>> vreg-immediate-bitwise? ] [ \ ##xor-imm f insn>imm-insn ] }
|
||||||
|
{ [ dup src1>> vreg-immediate-bitwise? ] [ \ ##xor-imm t insn>imm-insn ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##shl rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src2>> vreg-immediate-bitwise? ] [ \ ##shl-imm f insn>imm-insn ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##shr rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src2>> vreg-immediate-bitwise? ] [ \ ##shr-imm f insn>imm-insn ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##sar rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src2>> vreg-immediate-bitwise? ] [ \ ##sar-imm f insn>imm-insn ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,14 @@
|
||||||
|
! Copyright (C) 2010 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors cpu.architecture kernel
|
||||||
|
compiler.cfg.instructions
|
||||||
|
compiler.cfg.gvn.graph
|
||||||
|
compiler.cfg.gvn.rewrite ;
|
||||||
|
IN: compiler.cfg.gvn.misc
|
||||||
|
|
||||||
|
M: ##replace rewrite
|
||||||
|
[ loc>> ] [ src>> vreg>insn ] bi
|
||||||
|
dup literal-insn? [
|
||||||
|
insn>literal dup immediate-store?
|
||||||
|
[ swap \ ##replace-imm new-insn ] [ 2drop f ] if
|
||||||
|
] [ 2drop f ] if ;
|
||||||
|
|
@ -0,0 +1,48 @@
|
||||||
|
! Copyright (C) 2010 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors combinators combinators.short-circuit kernel
|
||||||
|
layouts math cpu.architecture
|
||||||
|
compiler.cfg.instructions
|
||||||
|
compiler.cfg.gvn.graph ;
|
||||||
|
IN: compiler.cfg.gvn.rewrite
|
||||||
|
|
||||||
|
! Outputs f to mean no change
|
||||||
|
GENERIC: rewrite ( insn -- insn/f )
|
||||||
|
|
||||||
|
M: insn rewrite drop f ;
|
||||||
|
|
||||||
|
! Utilities
|
||||||
|
GENERIC: insn>integer ( insn -- n )
|
||||||
|
|
||||||
|
M: ##load-integer insn>integer val>> ;
|
||||||
|
|
||||||
|
: vreg>integer ( vreg -- n ) vreg>insn insn>integer ; inline
|
||||||
|
|
||||||
|
: vreg-immediate-arithmetic? ( vreg -- ? )
|
||||||
|
vreg>insn {
|
||||||
|
[ ##load-integer? ]
|
||||||
|
[ val>> immediate-arithmetic? ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
: vreg-immediate-bitwise? ( vreg -- ? )
|
||||||
|
vreg>insn {
|
||||||
|
[ ##load-integer? ]
|
||||||
|
[ val>> immediate-bitwise? ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
UNION: literal-insn ##load-integer ##load-reference ;
|
||||||
|
|
||||||
|
GENERIC: insn>literal ( insn -- n )
|
||||||
|
|
||||||
|
M: ##load-integer insn>literal val>> >fixnum ;
|
||||||
|
|
||||||
|
M: ##load-reference insn>literal obj>> ;
|
||||||
|
|
||||||
|
: vreg>literal ( vreg -- n ) vreg>insn insn>literal ; inline
|
||||||
|
|
||||||
|
: vreg-immediate-comparand? ( vreg -- ? )
|
||||||
|
vreg>insn {
|
||||||
|
{ [ dup ##load-integer? ] [ val>> tag-fixnum immediate-comparand? ] }
|
||||||
|
{ [ dup ##load-reference? ] [ obj>> immediate-comparand? ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
|
||||||
|
|
@ -0,0 +1,163 @@
|
||||||
|
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors combinators combinators.short-circuit arrays
|
||||||
|
fry kernel layouts math namespaces sequences cpu.architecture
|
||||||
|
math.bitwise math.order classes generalizations
|
||||||
|
combinators.smart locals make alien.c-types io.binary grouping
|
||||||
|
math.vectors.simd.intrinsics
|
||||||
|
compiler.cfg
|
||||||
|
compiler.cfg.registers
|
||||||
|
compiler.cfg.utilities
|
||||||
|
compiler.cfg.comparisons
|
||||||
|
compiler.cfg.instructions
|
||||||
|
compiler.cfg.gvn.math
|
||||||
|
compiler.cfg.gvn.graph
|
||||||
|
compiler.cfg.gvn.rewrite ;
|
||||||
|
IN: compiler.cfg.gvn.simd
|
||||||
|
|
||||||
|
! Some lame constant folding for SIMD intrinsics. Eventually this
|
||||||
|
! should be redone completely.
|
||||||
|
|
||||||
|
: useless-shuffle-vector-imm? ( insn -- ? )
|
||||||
|
[ shuffle>> ] [ rep>> rep-length iota ] bi sequence= ;
|
||||||
|
|
||||||
|
: compose-shuffle-vector-imm ( outer inner -- insn' )
|
||||||
|
2dup [ rep>> ] bi@ eq? [
|
||||||
|
[ [ dst>> ] [ src>> ] bi* ]
|
||||||
|
[ [ shuffle>> ] bi@ nths ]
|
||||||
|
[ drop rep>> ]
|
||||||
|
2tri \ ##shuffle-vector-imm new-insn
|
||||||
|
] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
: (fold-shuffle-vector-imm) ( shuffle bytes -- bytes' )
|
||||||
|
2dup length swap length /i group nths concat ;
|
||||||
|
|
||||||
|
: fold-shuffle-vector-imm ( outer inner -- insn' )
|
||||||
|
[ [ dst>> ] [ shuffle>> ] bi ] [ obj>> ] bi*
|
||||||
|
(fold-shuffle-vector-imm) \ ##load-reference new-insn ;
|
||||||
|
|
||||||
|
M: ##shuffle-vector-imm rewrite
|
||||||
|
dup src>> vreg>insn {
|
||||||
|
{ [ over useless-shuffle-vector-imm? ] [ drop [ dst>> ] [ src>> ] bi <copy> ] }
|
||||||
|
{ [ dup ##shuffle-vector-imm? ] [ compose-shuffle-vector-imm ] }
|
||||||
|
{ [ dup ##load-reference? ] [ fold-shuffle-vector-imm ] }
|
||||||
|
[ 2drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: scalar-value ( literal-insn rep -- byte-array )
|
||||||
|
{
|
||||||
|
{ float-4-rep [ obj>> float>bits 4 >le ] }
|
||||||
|
{ double-2-rep [ obj>> double>bits 8 >le ] }
|
||||||
|
[ [ val>> ] [ rep-component-type heap-size ] bi* >le ]
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
: (fold-scalar>vector) ( insn bytes -- insn' )
|
||||||
|
[ [ dst>> ] [ rep>> rep-length ] bi ] dip <repetition> concat
|
||||||
|
\ ##load-reference new-insn ;
|
||||||
|
|
||||||
|
: fold-scalar>vector ( outer inner -- insn' )
|
||||||
|
over rep>> scalar-value (fold-scalar>vector) ;
|
||||||
|
|
||||||
|
M: ##scalar>vector rewrite
|
||||||
|
dup src>> vreg>insn {
|
||||||
|
{ [ dup literal-insn? ] [ fold-scalar>vector ] }
|
||||||
|
{ [ dup ##vector>scalar? ] [ [ dst>> ] [ src>> ] bi* <copy> ] }
|
||||||
|
[ 2drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
:: fold-gather-vector-2 ( insn src1 src2 -- insn )
|
||||||
|
insn dst>>
|
||||||
|
src1 src2 [ insn rep>> scalar-value ] bi@ append
|
||||||
|
\ ##load-reference new-insn ;
|
||||||
|
|
||||||
|
: rewrite-gather-vector-2 ( insn -- insn/f )
|
||||||
|
dup [ src1>> vreg>insn ] [ src2>> vreg>insn ] bi {
|
||||||
|
{ [ 2dup [ literal-insn? ] both? ] [ fold-gather-vector-2 ] }
|
||||||
|
[ 3drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##gather-vector-2 rewrite rewrite-gather-vector-2 ;
|
||||||
|
|
||||||
|
M: ##gather-int-vector-2 rewrite rewrite-gather-vector-2 ;
|
||||||
|
|
||||||
|
:: fold-gather-vector-4 ( insn src1 src2 src3 src4 -- insn )
|
||||||
|
insn dst>>
|
||||||
|
[
|
||||||
|
src1 src2 src3 src4
|
||||||
|
[ insn rep>> scalar-value ] 4 napply
|
||||||
|
] B{ } append-outputs-as
|
||||||
|
\ ##load-reference new-insn ;
|
||||||
|
|
||||||
|
: rewrite-gather-vector-4 ( insn -- insn/f )
|
||||||
|
dup { [ src1>> ] [ src2>> ] [ src3>> ] [ src4>> ] } cleave [ vreg>insn ] 4 napply
|
||||||
|
{
|
||||||
|
{ [ 4 ndup [ literal-insn? ] 4 napply and and and ] [ fold-gather-vector-4 ] }
|
||||||
|
[ 5 ndrop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##gather-vector-4 rewrite rewrite-gather-vector-4 ;
|
||||||
|
|
||||||
|
M: ##gather-int-vector-4 rewrite rewrite-gather-vector-4 ;
|
||||||
|
|
||||||
|
: fold-shuffle-vector ( insn src1 src2 -- insn )
|
||||||
|
[ dst>> ] [ obj>> ] [ obj>> ] tri*
|
||||||
|
swap nths \ ##load-reference new-insn ;
|
||||||
|
|
||||||
|
M: ##shuffle-vector rewrite
|
||||||
|
dup [ src>> vreg>insn ] [ shuffle>> vreg>insn ] bi
|
||||||
|
{
|
||||||
|
{ [ 2dup [ ##load-reference? ] both? ] [ fold-shuffle-vector ] }
|
||||||
|
[ 3drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##xor-vector rewrite
|
||||||
|
dup diagonal?
|
||||||
|
[ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
|
||||||
|
|
||||||
|
: vector-not? ( insn -- ? )
|
||||||
|
{
|
||||||
|
[ ##not-vector? ]
|
||||||
|
[ {
|
||||||
|
[ ##xor-vector? ]
|
||||||
|
[ [ src1>> ] [ src2>> ] bi [ vreg>insn ##fill-vector? ] either? ]
|
||||||
|
} 1&& ]
|
||||||
|
} 1|| ;
|
||||||
|
|
||||||
|
GENERIC: vector-not-src ( insn -- vreg )
|
||||||
|
|
||||||
|
M: ##not-vector vector-not-src
|
||||||
|
src>> ;
|
||||||
|
|
||||||
|
M: ##xor-vector vector-not-src
|
||||||
|
dup src1>> vreg>insn ##fill-vector? [ src2>> ] [ src1>> ] if ;
|
||||||
|
|
||||||
|
M: ##and-vector rewrite
|
||||||
|
{
|
||||||
|
{ [ dup src1>> vreg>insn vector-not? ] [
|
||||||
|
{
|
||||||
|
[ dst>> ]
|
||||||
|
[ src1>> vreg>insn vector-not-src ]
|
||||||
|
[ src2>> ]
|
||||||
|
[ rep>> ]
|
||||||
|
} cleave \ ##andn-vector new-insn
|
||||||
|
] }
|
||||||
|
{ [ dup src2>> vreg>insn vector-not? ] [
|
||||||
|
{
|
||||||
|
[ dst>> ]
|
||||||
|
[ src2>> vreg>insn vector-not-src ]
|
||||||
|
[ src1>> ]
|
||||||
|
[ rep>> ]
|
||||||
|
} cleave \ ##andn-vector new-insn
|
||||||
|
] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: ##andn-vector rewrite
|
||||||
|
dup src1>> vreg>insn vector-not? [
|
||||||
|
{
|
||||||
|
[ dst>> ]
|
||||||
|
[ src1>> vreg>insn vector-not-src ]
|
||||||
|
[ src2>> ]
|
||||||
|
[ rep>> ]
|
||||||
|
} cleave \ ##and-vector new-insn
|
||||||
|
] [ drop f ] if ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,24 @@
|
||||||
|
! Copyright (C) 2010 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors combinators.short-circuit cpu.architecture fry
|
||||||
|
kernel math
|
||||||
|
compiler.cfg.instructions
|
||||||
|
compiler.cfg.gvn.graph
|
||||||
|
compiler.cfg.gvn.rewrite ;
|
||||||
|
IN: compiler.cfg.gvn.slots
|
||||||
|
|
||||||
|
: simplify-slot-addressing? ( insn -- ? )
|
||||||
|
complex-addressing?
|
||||||
|
[ slot>> vreg>insn ##add-imm? ] [ drop f ] if ;
|
||||||
|
|
||||||
|
: simplify-slot-addressing ( insn -- insn/f )
|
||||||
|
dup simplify-slot-addressing? [
|
||||||
|
dup slot>> vreg>insn
|
||||||
|
[ src1>> >>slot ]
|
||||||
|
[ src2>> over scale>> '[ _ _ shift - ] change-tag ]
|
||||||
|
bi
|
||||||
|
] [ drop f ] if ;
|
||||||
|
|
||||||
|
M: ##slot rewrite simplify-slot-addressing ;
|
||||||
|
M: ##set-slot rewrite simplify-slot-addressing ;
|
||||||
|
M: ##write-barrier rewrite simplify-slot-addressing ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Global value numbering for common subexpression elimination
|
||||||
Loading…
Reference in New Issue