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