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*
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
} 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
: 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 ;
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 } ;
INSN: ##write-barrier < ##effect card# table ;
-INSN: ##alien-global < ##read symbol library ;
+INSN: ##alien-global < ##flushable symbol library ;
! FFI
INSN: ##alien-invoke params ;
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
##branch
##loop-entry
##conditional-branch
- ##compare-imm-branch ;
+ ##compare-imm-branch
+ ##dispatch ;
M: neutral-insn 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
M: ##alien-callback visit , ;
-M: ##dispatch-label visit , ;
-
! Maps basic-blocks to states
SYMBOLS: state-in state-out ;
[
drop
dup [ not ] any? [
- 2drop <state>
+ [ <state> ] 2dip
+ sift merge-heights
] [
dup [ poisoned?>> ] any? [
cannot-merge-poisoned
[ 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
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 )
{
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 -- )
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
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
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
: 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