More powerful templating
parent
ec1890b2b3
commit
7f5e240e98
|
@ -1,178 +0,0 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: compiler
|
||||
USING: arrays hashtables kernel lists math namespaces sequences ;
|
||||
|
||||
! Optimizations performed here:
|
||||
! - combining %inc-d/%inc-r within a single basic block
|
||||
! - if a literal is loaded into a vreg but the vreg is
|
||||
! overwritten before being read, the literal load is deleted
|
||||
! - if a %replace is writing a vreg to a stack location already
|
||||
! holding that vreg, or a stack location that is not read
|
||||
! before being popped, the %replace is deleted
|
||||
! - if a %peek is reading a stack location into a vreg that
|
||||
! already holds that vreg, or if the vreg is overwritten
|
||||
! before being read, the %peek is deleted
|
||||
! - removing dead loads of stack locations into vregs
|
||||
! - removing dead stores of vregs into stack locations
|
||||
|
||||
: vop-in ( vop n -- input ) swap vop-inputs nth ;
|
||||
: set-vop-in ( input vop n -- ) swap vop-inputs set-nth ;
|
||||
: vop-out ( vop n -- input ) swap vop-outputs nth ;
|
||||
: set-vop-out ( output vop n -- ) swap vop-outputs set-nth ;
|
||||
|
||||
: (split-blocks) ( n linear -- )
|
||||
2dup length = [
|
||||
dup like , drop
|
||||
] [
|
||||
2dup nth basic-block? [
|
||||
>r 1+ r> (split-blocks)
|
||||
] [
|
||||
(cut) >r , 1 r> (cut) >r , 0 r> (split-blocks)
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: split-blocks ( linear -- blocks )
|
||||
[ 0 swap (split-blocks) ] { } make ;
|
||||
|
||||
SYMBOL: d-height
|
||||
SYMBOL: r-height
|
||||
|
||||
! combining %inc-d/%inc-r
|
||||
GENERIC: simplify-stack* ( vop -- )
|
||||
|
||||
M: tuple simplify-stack* ( vop -- ) drop ;
|
||||
|
||||
: accum-height ( vop var -- )
|
||||
>r dup 0 vop-in r> [ + ] change 0 swap 0 set-vop-in ;
|
||||
|
||||
M: %inc-d simplify-stack* ( vop -- ) d-height accum-height ;
|
||||
|
||||
M: %inc-r simplify-stack* ( vop -- ) r-height accum-height ;
|
||||
|
||||
GENERIC: update-loc ( loc -- loc )
|
||||
|
||||
M: ds-loc update-loc ds-loc-n d-height get - <ds-loc> ;
|
||||
|
||||
M: cs-loc update-loc cs-loc-n r-height get - <cs-loc> ;
|
||||
|
||||
M: %peek simplify-stack* ( vop -- )
|
||||
0 [ vop-in update-loc ] 2keep set-vop-in ;
|
||||
|
||||
M: %replace simplify-stack* ( vop -- )
|
||||
0 [ vop-out update-loc ] 2keep set-vop-out ;
|
||||
|
||||
: simplify-stack ( block -- )
|
||||
#! Combine all %inc-d/%inc-r into two final ones.
|
||||
#! Destructively modifies the VOPs in the block.
|
||||
[ simplify-stack* ] each ;
|
||||
|
||||
: each-tail ( seq quot -- | quot: tail -- )
|
||||
>r dup length [ swap tail-slice ] map-with r> each ; inline
|
||||
|
||||
! removing dead loads/stores
|
||||
: preserves-location? ( exitcc location vop -- ? )
|
||||
#! If the VOP writes the register, call the loop exit
|
||||
#! continuation with 'f'.
|
||||
{
|
||||
{ [ 2dup vop-inputs member? ] [ 3drop t ] }
|
||||
{ [ 2dup vop-outputs member? ] [ 2drop f swap continue-with ] }
|
||||
{ [ t ] [ 3drop f ] }
|
||||
} cond ;
|
||||
|
||||
GENERIC: live@end? ( location -- ? )
|
||||
|
||||
M: tuple live@end? drop t ;
|
||||
|
||||
M: ds-loc live@end? ds-loc-n d-height get + 0 >= ;
|
||||
|
||||
M: cs-loc live@end? cs-loc-n r-height get + 0 >= ;
|
||||
|
||||
: location-live? ( location tail -- ? )
|
||||
#! A location is not live if and only if it is overwritten
|
||||
#! before the end of the basic block.
|
||||
[
|
||||
-rot [ >r 2dup r> preserves-location? ] contains?
|
||||
[ dup live@end? ] unless*
|
||||
] callcc1 2nip ;
|
||||
|
||||
! Used for elimination of dead loads from the stack:
|
||||
! we keep a map of vregs to ds-loc/cs-loc/f.
|
||||
SYMBOL: vreg-contents
|
||||
|
||||
GENERIC: trim-dead* ( tail vop -- )
|
||||
|
||||
: forget-vregs ( vop -- )
|
||||
vop-outputs [ vreg-contents get remove-hash ] each ;
|
||||
|
||||
M: tuple trim-dead* ( tail vop -- ) dup forget-vregs , drop ;
|
||||
|
||||
: ?, [ , ] [ drop ] if ;
|
||||
|
||||
: simplify-inc ( vop -- ) dup 0 vop-in zero? not ?, ;
|
||||
|
||||
M: %inc-d trim-dead* ( tail vop -- ) simplify-inc drop ;
|
||||
|
||||
M: %inc-r trim-dead* ( tail vop -- ) simplify-inc drop ;
|
||||
|
||||
: live-load? ( tail vop -- ? )
|
||||
#! If the VOP's output location is overwritten before being
|
||||
#! read again, kill the VOP.
|
||||
0 vop-out swap location-live? ;
|
||||
|
||||
: remember-peek ( vop -- )
|
||||
dup 0 vop-in swap 0 vop-out vreg-contents get set-hash ;
|
||||
|
||||
: redundant-peek? ( vop -- ? )
|
||||
dup 0 vop-in swap 0 vop-out vreg-contents get hash = ;
|
||||
|
||||
M: %peek trim-dead* ( tail vop -- )
|
||||
dup redundant-peek? >r tuck live-load? not r> or
|
||||
[ dup remember-peek dup , ] unless drop ;
|
||||
|
||||
: redundant-replace? ( vop -- ? )
|
||||
dup 0 vop-out swap 0 vop-in vreg-contents get hash = ;
|
||||
|
||||
: forget-stack-loc ( loc -- )
|
||||
#! Forget that any vregs hold this stack location.
|
||||
vreg-contents [ [ nip swap = not ] hash-subset-with ] change ;
|
||||
|
||||
: remember-replace ( vop -- )
|
||||
#! If a vreg claims to hold the stack location we are
|
||||
#! writing to, we must forget this fact, since that stack
|
||||
#! location no longer holds this value!
|
||||
dup 0 vop-out forget-stack-loc
|
||||
dup 0 vop-out swap 0 vop-in vreg-contents get set-hash ;
|
||||
|
||||
M: %replace trim-dead* ( tail vop -- )
|
||||
dup redundant-replace? >r tuck live-load? not r> or
|
||||
[ dup remember-replace dup , ] unless drop ;
|
||||
|
||||
: ?dead-literal dup forget-vregs tuck live-load? ?, ;
|
||||
|
||||
M: %immediate trim-dead* ( tail vop -- ) ?dead-literal ;
|
||||
|
||||
M: %indirect trim-dead* ( tail vop -- ) ?dead-literal ;
|
||||
|
||||
: trim-dead ( block -- )
|
||||
#! Remove dead loads and stores.
|
||||
[ dup first >r 1 swap tail-slice r> trim-dead* ] each-tail ;
|
||||
|
||||
: simplify-block ( block -- block )
|
||||
#! Destructively modifies the VOPs in the block.
|
||||
[
|
||||
0 d-height set
|
||||
0 r-height set
|
||||
H{ } clone vreg-contents set
|
||||
dup simplify-stack
|
||||
d-height get %inc-d r-height get %inc-r 2array append
|
||||
trim-dead
|
||||
] { } make ;
|
||||
|
||||
: keep-simplifying ( block -- block )
|
||||
dup length >r simplify-block dup length r> =
|
||||
[ keep-simplifying ] unless ;
|
||||
|
||||
: simplify ( blocks -- blocks )
|
||||
#! Simplify basic block IR.
|
||||
[ keep-simplifying ] map ;
|
|
@ -61,6 +61,9 @@ M: object vreg>stack ( value loc -- )
|
|||
[ dup zero? [ 2drop ] [ swap execute , ] if 0 ] change ;
|
||||
inline
|
||||
|
||||
: reset-stack ( vector -- )
|
||||
0 swap set-length ;
|
||||
|
||||
: end-basic-block ( -- )
|
||||
\ %inc-d d-height finalize-height
|
||||
\ %inc-r r-height finalize-height
|
||||
|
@ -68,8 +71,8 @@ M: object vreg>stack ( value loc -- )
|
|||
phantom-r get [ <cs-loc> ] f vregs>stack
|
||||
phantom-d get [ <ds-loc> ] t vregs>stack
|
||||
phantom-r get [ <cs-loc> ] t vregs>stack
|
||||
0 phantom-d get set-length
|
||||
0 phantom-r get set-length ;
|
||||
phantom-d get reset-stack
|
||||
phantom-r get reset-stack ;
|
||||
|
||||
G: stack>vreg ( value vreg loc -- operand )
|
||||
2 standard-combination ;
|
||||
|
@ -98,14 +101,41 @@ SYMBOL: any-reg
|
|||
3array flip
|
||||
[ first3 over [ stack>vreg ] [ 3drop f ] if ] map ;
|
||||
|
||||
: phantom-vregs ( phantom template -- )
|
||||
[ second ] map [ set ] 2each ;
|
||||
|
||||
: stack>vregs ( stack template quot -- )
|
||||
>r unpair -rot alloc-regs dup length reverse r> map
|
||||
(stack>vregs) swap [ set ] 2each ; inline
|
||||
>r dup [ first ] map swapd alloc-regs
|
||||
dup length reverse r> map
|
||||
(stack>vregs) swap phantom-vregs ; inline
|
||||
|
||||
: compatible-vreg?
|
||||
swap dup value? [ 2drop t ] [ vreg-n = ] if ;
|
||||
|
||||
: compatible-values? ( value template -- ? )
|
||||
{
|
||||
{ [ dup any-reg eq? ] [ 2drop t ] }
|
||||
{ [ dup integer? ] [ compatible-vreg? ] }
|
||||
{ [ dup value eq? ] [ drop value? ] }
|
||||
} cond ;
|
||||
|
||||
: template-match? ( phantom template -- ? )
|
||||
2dup [ length ] 2apply = [
|
||||
f [ first compatible-values? and ] 2reduce
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: template-input ( values template phantom quot -- )
|
||||
>r swap [ template-match? ] 2keep rot [
|
||||
rot r> 2drop over >r phantom-vregs r> reset-stack
|
||||
] [
|
||||
nip end-basic-block r> stack>vregs
|
||||
] if ; inline
|
||||
|
||||
: template-inputs ( stack template stack template -- )
|
||||
end-basic-block
|
||||
over >r [ <cs-loc> ] stack>vregs
|
||||
over >r [ <ds-loc> ] stack>vregs
|
||||
over >r phantom-r get [ <cs-loc> ] template-input
|
||||
over >r phantom-d get [ <ds-loc> ] template-input
|
||||
r> r> [ length neg ] 2apply adjust-stacks ;
|
||||
|
||||
: >phantom ( seq stack -- )
|
||||
|
|
Loading…
Reference in New Issue