diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 0a3671034d..7ea02c81e5 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -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 diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 1bf5bab067..38075c24a3 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -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 ; - -: ( 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 - ] [ - f emit-call - ] if ; + ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ; ! #call M: #call emit-node diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index bc0eb74554..65191d5ac2 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -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 ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 747233dbba..6da9f797bd 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -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 ; diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor index b81d9f81f5..923fe828b5 100644 --- a/basis/compiler/cfg/optimizer/optimizer-tests.factor +++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor @@ -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 diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index 0aa402ed66..ffff728ece 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -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 + [ ] 2dip + sift merge-heights ] [ dup [ poisoned?>> ] any? [ cannot-merge-poisoned diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index c12b5afd2e..5063273bf4 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -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 diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index c7b67b72b4..11b4e153f6 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -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 ) { diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index de5d1da4e0..98d0c5326b 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -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 -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 617a7c5141..934b456075 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -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 diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 0a0ac4a53e..4492a3d762 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -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 diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index b77539b7e7..0b9b4e8ddf 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -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 diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index e12cec9738..8ab247f5e5 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -79,9 +79,6 @@ M: x86 %return ( -- ) 0 RET ; : align-code ( n -- ) 0 % ; -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