Fixing various bugs; alias analysis wasn't handling ##phi nodes, stack analysis incorrectly handled height-changing back edges and ##fixnum-*, clean up ##dispatch generation
Slava Pestov
parent
ceb332f596
commit
76d74c16af
|
|
@ -215,13 +215,7 @@ GENERIC: analyze-aliases* ( insn -- insn' )
|
|||
M: ##load-immediate analyze-aliases*
|
||||
dup [ val>> ] [ dst>> ] bi constants get set-at ;
|
||||
|
||||
M: ##peek analyze-aliases*
|
||||
dup dst>> set-heap-ac ;
|
||||
|
||||
M: ##load-reference analyze-aliases*
|
||||
dup dst>> set-heap-ac ;
|
||||
|
||||
M: ##alien-global analyze-aliases*
|
||||
M: ##flushable analyze-aliases*
|
||||
dup dst>> set-heap-ac ;
|
||||
|
||||
M: ##allocation analyze-aliases*
|
||||
|
|
@ -230,7 +224,7 @@ M: ##allocation analyze-aliases*
|
|||
dup dst>> set-new-ac ;
|
||||
|
||||
M: ##read analyze-aliases*
|
||||
dup dst>> set-heap-ac
|
||||
call-next-method
|
||||
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
|
||||
2dup live-slot dup [
|
||||
2nip f \ ##copy boa analyze-aliases* nip
|
||||
|
|
|
|||
|
|
@ -159,63 +159,8 @@ M: #if emit-node
|
|||
} cond iterate-next ;
|
||||
|
||||
! #dispatch
|
||||
: trivial-dispatch-branch? ( nodes -- ? )
|
||||
dup length 1 = [
|
||||
first dup #call? [
|
||||
word>> "intrinsic" word-prop not
|
||||
] [ drop f ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
: dispatch-branch ( nodes word -- label )
|
||||
over trivial-dispatch-branch? [
|
||||
drop first word>>
|
||||
] [
|
||||
gensym [
|
||||
[
|
||||
V{ } clone node-stack set
|
||||
##prologue
|
||||
begin-basic-block
|
||||
emit-nodes
|
||||
basic-block get [
|
||||
##epilogue
|
||||
##return
|
||||
end-basic-block
|
||||
] when
|
||||
] with-cfg-builder
|
||||
] keep
|
||||
] if ;
|
||||
|
||||
: dispatch-branches ( node -- )
|
||||
children>> [
|
||||
current-word get dispatch-branch
|
||||
##dispatch-label
|
||||
] each ;
|
||||
|
||||
: emit-dispatch ( node -- )
|
||||
##epilogue
|
||||
ds-pop ^^offset>slot i 0 ##dispatch
|
||||
dispatch-branches ;
|
||||
|
||||
! If a dispatch is not in tail position, we compile a new word where the dispatch is in
|
||||
! tail position, then call this word.
|
||||
|
||||
: (non-tail-dispatch) ( -- word )
|
||||
gensym dup t "inlined-block" set-word-prop ;
|
||||
|
||||
: <non-tail-dispatch> ( node -- word )
|
||||
current-word get (non-tail-dispatch) [
|
||||
[
|
||||
begin-word
|
||||
emit-dispatch
|
||||
] with-cfg-builder
|
||||
] keep ;
|
||||
|
||||
M: #dispatch emit-node
|
||||
tail-call? [
|
||||
emit-dispatch stop-iterating
|
||||
] [
|
||||
<non-tail-dispatch> f emit-call
|
||||
] if ;
|
||||
ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
|
||||
|
||||
! #call
|
||||
M: #call emit-node
|
||||
|
|
|
|||
|
|
@ -10,13 +10,13 @@ ERROR: last-insn-not-a-jump insn ;
|
|||
: check-last-instruction ( bb -- )
|
||||
peek dup {
|
||||
[ ##branch? ]
|
||||
[ ##dispatch? ]
|
||||
[ ##conditional-branch? ]
|
||||
[ ##compare-imm-branch? ]
|
||||
[ ##return? ]
|
||||
[ ##callback-return? ]
|
||||
[ ##jump? ]
|
||||
[ ##call? ]
|
||||
[ ##dispatch-label? ]
|
||||
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
|
||||
|
||||
ERROR: bad-loop-entry ;
|
||||
|
|
|
|||
|
|
@ -57,13 +57,12 @@ TUPLE: stack-frame
|
|||
spill-counts ;
|
||||
|
||||
INSN: ##stack-frame stack-frame ;
|
||||
INSN: ##call word height ;
|
||||
INSN: ##call word { height integer } ;
|
||||
INSN: ##jump word ;
|
||||
INSN: ##return ;
|
||||
|
||||
! Jump tables
|
||||
INSN: ##dispatch src temp offset ;
|
||||
INSN: ##dispatch-label label ;
|
||||
INSN: ##dispatch src temp ;
|
||||
|
||||
! Slot access
|
||||
INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
|
||||
|
|
@ -165,7 +164,7 @@ UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
|
|||
|
||||
INSN: ##write-barrier < ##effect card# table ;
|
||||
|
||||
INSN: ##alien-global < ##read symbol library ;
|
||||
INSN: ##alien-global < ##flushable symbol library ;
|
||||
|
||||
! FFI
|
||||
INSN: ##alien-invoke params ;
|
||||
|
|
|
|||
|
|
@ -1,14 +1,33 @@
|
|||
USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
|
||||
compiler.cfg.def-use sets kernel kernel.private fry slots.private ;
|
||||
compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors
|
||||
sequences.private math sbufs math.private slots.private strings ;
|
||||
IN: compiler.cfg.optimizer.tests
|
||||
|
||||
! Miscellaneous tests
|
||||
|
||||
: more? ( x -- ? ) ;
|
||||
|
||||
: test-case-1 ( -- ? ) f ;
|
||||
|
||||
: test-case-2 ( -- )
|
||||
test-case-1 [ test-case-2 ] [ ] if ; inline recursive
|
||||
|
||||
{
|
||||
[ 1array ]
|
||||
[ 1 2 ? ]
|
||||
[ { array } declare [ ] map ]
|
||||
[ { array } declare dup 1 slot [ 1 slot ] when ]
|
||||
[ [ dup more? ] [ dup ] produce ]
|
||||
[ vector new over test-case-1 [ test-case-2 ] [ ] if ]
|
||||
[ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
|
||||
[
|
||||
{ fixnum sbuf } declare 2dup 3 slot fixnum> [
|
||||
over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
|
||||
] [ ] if
|
||||
]
|
||||
[ [ 2 fixnum* ] when 3 ]
|
||||
[ [ 2 fixnum+ ] when 3 ]
|
||||
[ [ 2 fixnum- ] when 3 ]
|
||||
} [
|
||||
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
|
||||
] each
|
||||
|
|
|
|||
|
|
@ -91,7 +91,8 @@ UNION: neutral-insn
|
|||
##branch
|
||||
##loop-entry
|
||||
##conditional-branch
|
||||
##compare-imm-branch ;
|
||||
##compare-imm-branch
|
||||
##dispatch ;
|
||||
|
||||
M: neutral-insn visit , ;
|
||||
|
||||
|
|
@ -130,22 +131,12 @@ M: ##copy visit
|
|||
[ call-next-method ] [ record-copy ] bi ;
|
||||
|
||||
M: ##call visit
|
||||
[ call-next-method ] [ height>> [ adjust-d ] [ poison-state ] if* ] bi ;
|
||||
|
||||
M: ##fixnum-mul visit
|
||||
call-next-method -1 adjust-d ;
|
||||
|
||||
M: ##fixnum-add visit
|
||||
call-next-method -1 adjust-d ;
|
||||
|
||||
M: ##fixnum-sub visit
|
||||
call-next-method -1 adjust-d ;
|
||||
[ call-next-method ] [ height>> adjust-d ] bi ;
|
||||
|
||||
! Instructions that poison the stack state
|
||||
UNION: poison-insn
|
||||
##jump
|
||||
##return
|
||||
##dispatch
|
||||
##callback-return
|
||||
##fixnum-mul-tail
|
||||
##fixnum-add-tail
|
||||
|
|
@ -179,8 +170,6 @@ M: ##alien-indirect visit
|
|||
|
||||
M: ##alien-callback visit , ;
|
||||
|
||||
M: ##dispatch-label visit , ;
|
||||
|
||||
! Maps basic-blocks to states
|
||||
SYMBOLS: state-in state-out ;
|
||||
|
||||
|
|
@ -245,7 +234,8 @@ ERROR: cannot-merge-poisoned states ;
|
|||
[
|
||||
drop
|
||||
dup [ not ] any? [
|
||||
2drop <state>
|
||||
[ <state> ] 2dip
|
||||
sift merge-heights
|
||||
] [
|
||||
dup [ poisoned?>> ] any? [
|
||||
cannot-merge-poisoned
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ sequences compiler.cfg vectors arrays ;
|
|||
[ t ] [
|
||||
{
|
||||
T{ ##peek f V int-regs 1 D 0 }
|
||||
T{ ##dispatch f V int-regs 1 V int-regs 2 0 }
|
||||
T{ ##dispatch f V int-regs 1 V int-regs 2 }
|
||||
} dup test-value-numbering =
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -92,10 +92,8 @@ M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
|
|||
|
||||
M: ##return generate-insn drop %return ;
|
||||
|
||||
M: ##dispatch-label generate-insn label>> %dispatch-label ;
|
||||
|
||||
M: ##dispatch generate-insn
|
||||
[ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
|
||||
[ src>> register ] [ temp>> register ] bi %dispatch ;
|
||||
|
||||
: >slot< ( insn -- dst obj slot tag )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -51,8 +51,7 @@ HOOK: %jump cpu ( word -- )
|
|||
HOOK: %jump-label cpu ( label -- )
|
||||
HOOK: %return cpu ( -- )
|
||||
|
||||
HOOK: %dispatch cpu ( src temp offset -- )
|
||||
HOOK: %dispatch-label cpu ( word -- )
|
||||
HOOK: %dispatch cpu ( src temp -- )
|
||||
|
||||
HOOK: %slot cpu ( dst obj slot tag temp -- )
|
||||
HOOK: %slot-imm cpu ( dst obj slot tag -- )
|
||||
|
|
|
|||
|
|
@ -124,16 +124,13 @@ M: ppc %jump ( word -- )
|
|||
M: ppc %jump-label ( label -- ) B ;
|
||||
M: ppc %return ( -- ) BLR ;
|
||||
|
||||
M:: ppc %dispatch ( src temp offset -- )
|
||||
M:: ppc %dispatch ( src temp -- )
|
||||
0 temp LOAD32
|
||||
4 offset + cells rc-absolute-ppc-2/2 rel-here
|
||||
4 cells rc-absolute-ppc-2/2 rel-here
|
||||
temp temp src LWZX
|
||||
temp MTCTR
|
||||
BCTR ;
|
||||
|
||||
M: ppc %dispatch-label ( word -- )
|
||||
B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
|
||||
|
||||
:: (%slot) ( obj slot tag temp -- reg offset )
|
||||
temp slot obj ADD
|
||||
temp tag neg ; inline
|
||||
|
|
|
|||
|
|
@ -26,10 +26,10 @@ M: x86.32 stack-reg ESP ;
|
|||
M: x86.32 temp-reg-1 ECX ;
|
||||
M: x86.32 temp-reg-2 EDX ;
|
||||
|
||||
M:: x86.32 %dispatch ( src temp offset -- )
|
||||
M:: x86.32 %dispatch ( src temp -- )
|
||||
! Load jump table base.
|
||||
src HEX: ffffffff ADD
|
||||
offset cells rc-absolute-cell rel-here
|
||||
0 rc-absolute-cell rel-here
|
||||
! Go
|
||||
src HEX: 7f [+] JMP
|
||||
! Fix up the displacement above
|
||||
|
|
|
|||
|
|
@ -22,10 +22,10 @@ M: x86.64 ds-reg R14 ;
|
|||
M: x86.64 rs-reg R15 ;
|
||||
M: x86.64 stack-reg RSP ;
|
||||
|
||||
M:: x86.64 %dispatch ( src temp offset -- )
|
||||
M:: x86.64 %dispatch ( src temp -- )
|
||||
! Load jump table base.
|
||||
temp HEX: ffffffff MOV
|
||||
offset cells rc-absolute-cell rel-here
|
||||
0 rc-absolute-cell rel-here
|
||||
! Add jump table base
|
||||
src temp ADD
|
||||
src HEX: 7f [+] JMP
|
||||
|
|
|
|||
|
|
@ -79,9 +79,6 @@ M: x86 %return ( -- ) 0 RET ;
|
|||
: align-code ( n -- )
|
||||
0 <repetition> % ;
|
||||
|
||||
M: x86 %dispatch-label ( word -- )
|
||||
0 cell, rc-absolute-cell rel-word ;
|
||||
|
||||
:: (%slot) ( obj slot tag temp -- op )
|
||||
temp slot obj [+] LEA
|
||||
temp tag neg [+] ; inline
|
||||
|
|
|
|||
Loading…
Reference in New Issue