USING: accessors assocs compiler.cfg
compiler.cfg.branch-splitting compiler.cfg.debugger
-compiler.cfg.predecessors compiler.cfg.rpo fry kernel
+compiler.cfg.predecessors compiler.cfg.rpo compiler.cfg.instructions fry kernel
tools.test namespaces sequences vectors ;
IN: compiler.cfg.branch-splitting.tests
: test-branch-splitting ( -- )
cfg new 0 get >>entry check-branch-splitting ;
-V{ } 0 test-bb
+V{ T{ ##branch } } 0 test-bb
-V{ } 1 test-bb
+V{ T{ ##branch } } 1 test-bb
-V{ } 2 test-bb
+V{ T{ ##branch } } 2 test-bb
-V{ } 3 test-bb
+V{ T{ ##branch } } 3 test-bb
-V{ } 4 test-bb
+V{ T{ ##branch } } 4 test-bb
test-diamond
[ ] [ test-branch-splitting ] unit-test
-V{ } 0 test-bb
+V{ T{ ##branch } } 0 test-bb
-V{ } 1 test-bb
+V{ T{ ##branch } } 1 test-bb
-V{ } 2 test-bb
+V{ T{ ##branch } } 2 test-bb
-V{ } 3 test-bb
+V{ T{ ##branch } } 3 test-bb
-V{ } 4 test-bb
+V{ T{ ##branch } } 4 test-bb
-V{ } 5 test-bb
+V{ T{ ##branch } } 5 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
[ ] [ test-branch-splitting ] unit-test
-V{ } 0 test-bb
+V{ T{ ##branch } } 0 test-bb
-V{ } 1 test-bb
+V{ T{ ##branch } } 1 test-bb
-V{ } 2 test-bb
+V{ T{ ##branch } } 2 test-bb
-V{ } 3 test-bb
+V{ T{ ##branch } } 3 test-bb
-V{ } 4 test-bb
+V{ T{ ##branch } } 4 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
[ ] [ test-branch-splitting ] unit-test
-V{ } 0 test-bb
+V{ T{ ##branch } } 0 test-bb
-V{ } 1 test-bb
+V{ T{ ##branch } } 1 test-bb
-V{ } 2 test-bb
+V{ T{ ##branch } } 2 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
: split-instructions? ( insns -- ? )
- [ irrelevant? not ] count 5 <= ;
+ [ [ irrelevant? not ] count 5 <= ]
+ [ last ##fixnum-overflow? not ]
+ bi and ;
: split-branch? ( bb -- ? )
{
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
combinators make classes words cpu.architecture
] when ;
\ _spill t frame-required? set-word-prop
-\ ##fixnum-add t frame-required? set-word-prop
-\ ##fixnum-sub t frame-required? set-word-prop
-\ ##fixnum-mul t frame-required? set-word-prop
-\ ##fixnum-add-tail f frame-required? set-word-prop
-\ ##fixnum-sub-tail f frame-required? set-word-prop
-\ ##fixnum-mul-tail f frame-required? set-word-prop
: compute-stack-frame ( insns -- )
frame-required? off
! #if
: emit-branch ( obj -- final-bb )
- [
- begin-basic-block
- emit-nodes
- basic-block get dup [ ##branch ] when
- ] with-scope ;
+ [ emit-nodes ] with-branch ;
: emit-if ( node -- )
- children>> [ emit-branch ] map
- end-basic-block
- begin-basic-block
- basic-block get '[ [ _ swap successors>> push ] when* ] each ;
+ children>> [ emit-branch ] map emit-conditional ;
: ##branch-t ( vreg -- )
\ f tag-number cc/= ##compare-imm-branch ;
[ ##return? ]
[ ##callback-return? ]
[ ##jump? ]
- [ ##fixnum-add-tail? ]
- [ ##fixnum-sub-tail? ]
- [ ##fixnum-mul-tail? ]
+ [ ##fixnum-add? ]
+ [ ##fixnum-sub? ]
+ [ ##fixnum-mul? ]
[ ##no-tco? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
GENERIC: uses-vregs ( insn -- seq )
M: ##flushable defs-vregs dst>> 1array ;
+M: ##fixnum-overflow defs-vregs dst>> 1array ;
M: insn defs-vregs drop f ;
M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
M: ##compare temp-vregs temp>> 1array ;
M: ##compare-imm temp-vregs temp>> 1array ;
M: ##compare-float temp-vregs temp>> 1array ;
-M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
-M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: _dispatch temp-vregs temp>> 1array ;
M: insn temp-vregs drop f ;
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
-
+: ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline
+: ^^fixnum-sub ( src1 src2 -- dst ) ^^i2 ##fixnum-sub ; inline
+: ^^fixnum-mul ( src1 src2 -- dst ) ^^i2 ##fixnum-mul ; inline
: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline
\ No newline at end of file
INSN: ##not < ##unary ;
INSN: ##log2 < ##unary ;
-! Overflowing arithmetic
-TUPLE: ##fixnum-overflow < insn src1 src2 ;
-INSN: ##fixnum-add < ##fixnum-overflow ;
-INSN: ##fixnum-add-tail < ##fixnum-overflow ;
-INSN: ##fixnum-sub < ##fixnum-overflow ;
-INSN: ##fixnum-sub-tail < ##fixnum-overflow ;
-INSN: ##fixnum-mul < ##fixnum-overflow temp1 temp2 ;
-INSN: ##fixnum-mul-tail < ##fixnum-overflow temp1 temp2 ;
-
: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
INSN: ##phi < ##pure inputs ;
+! Conditionals
TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
INSN: ##compare-branch < ##conditional-branch ;
INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc temp ;
+! Overflowing arithmetic
+TUPLE: ##fixnum-overflow < insn { dst vreg } { src1 vreg } { src2 vreg } ;
+INSN: ##fixnum-add < ##fixnum-overflow ;
+INSN: ##fixnum-sub < ##fixnum-overflow ;
+INSN: ##fixnum-mul < ##fixnum-overflow ;
+
INSN: ##gc { temp1 vreg } { temp2 vreg } live-values ;
! Instructions used by machine IR only.
INSN: _compare-float-branch < _conditional-branch ;
+! Overflowing arithmetic
+TUPLE: _fixnum-overflow < insn label { dst vreg } { src1 vreg } { src2 vreg } ;
+INSN: _fixnum-add < _fixnum-overflow ;
+INSN: _fixnum-sub < _fixnum-overflow ;
+INSN: _fixnum-mul < _fixnum-overflow ;
+
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
UNION: poison-insn
##jump
##return
- ##callback-return
- ##fixnum-mul-tail
- ##fixnum-add-tail
- ##fixnum-sub-tail ;
+ ##callback-return ;
! Instructions that kill all live vregs
UNION: kill-vreg-insn
##call
##prologue
##epilogue
- ##fixnum-mul
- ##fixnum-add
- ##fixnum-sub
##alien-invoke
##alien-indirect
##alien-callback ;
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors layouts kernel math namespaces
-combinators fry
+combinators fry arrays
compiler.tree.propagation.info
compiler.cfg.hats
compiler.cfg.stacks
: emit-fixnum>bignum ( -- )
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
-: emit-fixnum-overflow-op ( quot -- next )
- [ 2inputs 1 ##inc-d ] dip call ##branch
- begin-basic-block ; inline
+: emit-no-overflow-case ( dst -- final-bb )
+ [ -2 ##inc-d ds-push ] with-branch ;
+
+: emit-overflow-case ( word -- final-bb )
+ [ ##call ] with-branch ;
+
+: emit-fixnum-overflow-op ( quot word -- )
+ [ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip
+ [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
+ emit-conditional ; inline
+
+: fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ;
+
+: fixnum-overflow ( x y -- z ) [ >bignum ] bi@ - ;
+
+: fixnum*overflow ( x y -- z ) [ >bignum ] bi@ * ;
+
+: emit-fixnum+ ( -- )
+ [ ^^fixnum-add ] \ fixnum+overflow emit-fixnum-overflow-op ;
+
+: emit-fixnum- ( -- )
+ [ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ;
+
+: emit-fixnum* ( -- )
+ [ ^^untag-fixnum ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;
\ No newline at end of file
{ \ kernel.private:tag [ drop emit-tag ] }
{ \ kernel.private:getenv [ emit-getenv ] }
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
- { \ math.private:fixnum+ [ drop [ ##fixnum-add ] emit-fixnum-overflow-op ] }
- { \ math.private:fixnum- [ drop [ ##fixnum-sub ] emit-fixnum-overflow-op ] }
- { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] emit-fixnum-overflow-op ] }
+ { \ math.private:fixnum+ [ drop emit-fixnum+ ] }
+ { \ math.private:fixnum- [ drop emit-fixnum- ] }
+ { \ math.private:fixnum* [ drop emit-fixnum* ] }
{ \ math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
{ \ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
T{ ##replace { src V int-regs 85 } { loc D 1 } }
T{ ##replace { src V int-regs 89 } { loc D 4 } }
T{ ##replace { src V int-regs 96 } { loc R 0 } }
- T{ ##fixnum-mul
- { src1 V int-regs 128 }
- { src2 V int-regs 129 }
- { temp1 V int-regs 132 }
- { temp2 V int-regs 133 }
- }
+ T{ ##replace { src V int-regs 129 } { loc R 0 } }
T{ ##branch }
} 2 test-bb
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
-! Another push-all reduction to demonstrate numbering anamoly
-V{ T{ ##prologue } T{ ##branch } }
-0 test-bb
-
-V{
- T{ ##peek { dst V int-regs 1 } { loc D 0 } }
- T{ ##slot-imm
- { dst V int-regs 5 }
- { obj V int-regs 1 }
- { slot 3 }
- { tag 7 }
- }
- T{ ##peek { dst V int-regs 7 } { loc D 1 } }
- T{ ##slot-imm
- { dst V int-regs 12 }
- { obj V int-regs 7 }
- { slot 1 }
- { tag 6 }
- }
- T{ ##add
- { dst V int-regs 25 }
- { src1 V int-regs 5 }
- { src2 V int-regs 12 }
- }
- T{ ##compare-branch
- { src1 V int-regs 25 }
- { src2 V int-regs 5 }
- { cc cc> }
- }
-}
-1 test-bb
-
-V{
- T{ ##slot-imm
- { dst V int-regs 41 }
- { obj V int-regs 1 }
- { slot 2 }
- { tag 7 }
- }
- T{ ##slot-imm
- { dst V int-regs 44 }
- { obj V int-regs 41 }
- { slot 1 }
- { tag 6 }
- }
- T{ ##compare-branch
- { src1 V int-regs 25 }
- { src2 V int-regs 44 }
- { cc cc> }
- }
-}
-2 test-bb
-
-V{
- T{ ##add-imm
- { dst V int-regs 54 }
- { src1 V int-regs 25 }
- { src2 8 }
- }
- T{ ##load-immediate { dst V int-regs 55 } { val 24 } }
- T{ ##inc-d { n 4 } }
- T{ ##inc-r { n 1 } }
- T{ ##replace { src V int-regs 25 } { loc D 2 } }
- T{ ##replace { src V int-regs 1 } { loc D 3 } }
- T{ ##replace { src V int-regs 5 } { loc D 4 } }
- T{ ##replace { src V int-regs 1 } { loc D 1 } }
- T{ ##replace { src V int-regs 54 } { loc D 0 } }
- T{ ##replace { src V int-regs 12 } { loc R 0 } }
- T{ ##fixnum-mul
- { src1 V int-regs 54 }
- { src2 V int-regs 55 }
- { temp1 V int-regs 58 }
- { temp2 V int-regs 59 }
- }
- T{ ##branch }
-}
-3 test-bb
-
-V{
- T{ ##peek { dst V int-regs 60 } { loc D 1 } }
- T{ ##slot-imm
- { dst V int-regs 66 }
- { obj V int-regs 60 }
- { slot 2 }
- { tag 7 }
- }
- T{ ##inc-d { n 1 } }
- T{ ##inc-r { n 1 } }
- T{ ##replace { src V int-regs 66 } { loc D 0 } }
- T{ ##replace { src V int-regs 60 } { loc R 0 } }
- T{ ##call { word resize-string } }
- T{ ##branch }
-}
-4 test-bb
-
-V{
- T{ ##peek { dst V int-regs 67 } { loc R 0 } }
- T{ ##peek { dst V int-regs 68 } { loc D 0 } }
- T{ ##set-slot-imm
- { src V int-regs 68 }
- { obj V int-regs 67 }
- { slot 2 }
- { tag 7 }
- }
- T{ ##write-barrier
- { src V int-regs 67 }
- { card# V int-regs 75 }
- { table V int-regs 76 }
- }
- T{ ##inc-d { n -1 } }
- T{ ##inc-r { n -1 } }
- T{ ##peek { dst V int-regs 94 } { loc D 0 } }
- T{ ##peek { dst V int-regs 96 } { loc D 1 } }
- T{ ##peek { dst V int-regs 98 } { loc D 2 } }
- T{ ##peek { dst V int-regs 100 } { loc D 3 } }
- T{ ##peek { dst V int-regs 102 } { loc D 4 } }
- T{ ##peek { dst V int-regs 106 } { loc R 0 } }
- T{ ##copy { dst V int-regs 95 } { src V int-regs 94 } }
- T{ ##copy { dst V int-regs 97 } { src V int-regs 96 } }
- T{ ##copy { dst V int-regs 99 } { src V int-regs 98 } }
- T{ ##copy { dst V int-regs 101 } { src V int-regs 100 } }
- T{ ##copy { dst V int-regs 103 } { src V int-regs 102 } }
- T{ ##copy { dst V int-regs 107 } { src V int-regs 106 } }
- T{ ##branch }
-}
-5 test-bb
-
-V{
- T{ ##inc-d { n 3 } }
- T{ ##inc-r { n 1 } }
- T{ ##copy { dst V int-regs 95 } { src V int-regs 1 } }
- T{ ##copy { dst V int-regs 97 } { src V int-regs 25 } }
- T{ ##copy { dst V int-regs 99 } { src V int-regs 1 } }
- T{ ##copy { dst V int-regs 101 } { src V int-regs 5 } }
- T{ ##copy { dst V int-regs 103 } { src V int-regs 7 } }
- T{ ##copy { dst V int-regs 107 } { src V int-regs 12 } }
- T{ ##branch }
-}
-6 test-bb
-
-V{
- T{ ##load-immediate
- { dst V int-regs 78 }
- { val 4611686018427387896 }
- }
- T{ ##and
- { dst V int-regs 81 }
- { src1 V int-regs 97 }
- { src2 V int-regs 78 }
- }
- T{ ##set-slot-imm
- { src V int-regs 81 }
- { obj V int-regs 95 }
- { slot 3 }
- { tag 7 }
- }
- T{ ##inc-d { n -2 } }
- T{ ##copy { dst V int-regs 110 } { src V int-regs 99 } }
- T{ ##copy { dst V int-regs 111 } { src V int-regs 101 } }
- T{ ##copy { dst V int-regs 112 } { src V int-regs 103 } }
- T{ ##copy { dst V int-regs 117 } { src V int-regs 107 } }
- T{ ##branch }
-}
-7 test-bb
-
-V{
- T{ ##inc-d { n 1 } }
- T{ ##inc-r { n 1 } }
- T{ ##copy { dst V int-regs 110 } { src V int-regs 1 } }
- T{ ##copy { dst V int-regs 111 } { src V int-regs 5 } }
- T{ ##copy { dst V int-regs 112 } { src V int-regs 7 } }
- T{ ##copy { dst V int-regs 117 } { src V int-regs 12 } }
- T{ ##branch }
-}
-8 test-bb
-
-V{
- T{ ##inc-d { n 1 } }
- T{ ##inc-r { n -1 } }
- T{ ##replace { src V int-regs 117 } { loc D 0 } }
- T{ ##replace { src V int-regs 110 } { loc D 1 } }
- T{ ##replace { src V int-regs 111 } { loc D 2 } }
- T{ ##replace { src V int-regs 112 } { loc D 3 } }
- T{ ##epilogue }
- T{ ##return }
-}
-9 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 8 get V{ } 2sequence >>successors drop
-2 get 3 get 6 get V{ } 2sequence >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-5 get 7 get 1vector >>successors drop
-6 get 7 get 1vector >>successors drop
-7 get 9 get 1vector >>successors drop
-8 get 9 get 1vector >>successors drop
-
-[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
-
! Fencepost error in assignment pass
V{ T{ ##branch } } 0 test-bb
M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
+: successors ( bb -- first second ) successors>> first2 ; inline
+
: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
- [ dup successors>> first2 ]
+ [ dup successors ]
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
M: ##compare-float-branch linearize-insn
[ binary-conditional _compare-float-branch ] with-regs emit-branch ;
+: overflow-conditional ( basic-block insn -- basic-block successor label2 dst src1 src2 )
+ [ dup successors number>> ]
+ [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
+
+M: ##fixnum-add linearize-insn
+ [ overflow-conditional _fixnum-add ] with-regs emit-branch ;
+
+M: ##fixnum-sub linearize-insn
+ [ overflow-conditional _fixnum-sub ] with-regs emit-branch ;
+
+M: ##fixnum-mul linearize-insn
+ [ overflow-conditional _fixnum-mul ] with-regs emit-branch ;
+
M: ##dispatch linearize-insn
swap
[ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
M: ##compare-float fresh-insn-temps
[ fresh-vreg ] change-temp drop ;
-M: ##fixnum-mul fresh-insn-temps
- [ fresh-vreg ] change-temp1
- [ fresh-vreg ] change-temp2
- drop ;
-
-M: ##fixnum-mul-tail fresh-insn-temps
- [ fresh-vreg ] change-temp1
- [ fresh-vreg ] change-temp2
- drop ;
-
M: ##gc fresh-insn-temps
[ fresh-vreg ] change-temp1
[ fresh-vreg ] change-temp2
##conditional-branch
##compare-imm-branch
##dispatch
- ##loop-entry ;
+ ##loop-entry
+ ##fixnum-overflow ;
: sync-state? ( -- ? )
basic-block get successors>>
[ [ cfg get entry>> successors>> first ] dip successors>> push ]
tri ;
-: fixnum-tail-call? ( bb -- ? )
- instructions>> penultimate
- { [ ##fixnum-add? ] [ ##fixnum-sub? ] [ ##fixnum-mul? ] } 1|| ;
-
-GENERIC: convert-fixnum-tail-call* ( src1 src2 insn -- insn' )
-
-M: ##fixnum-add convert-fixnum-tail-call* drop \ ##fixnum-add-tail new-insn ;
-M: ##fixnum-sub convert-fixnum-tail-call* drop \ ##fixnum-sub-tail new-insn ;
-M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn ;
-
-: convert-fixnum-tail-call ( bb -- )
- [
- [ src1>> ] [ src2>> ] [ ] tri
- convert-fixnum-tail-call*
- ] convert-tail-call ;
-
: optimize-tail-call ( bb -- )
dup tail-call? [
{
{ [ dup loop-tail-call? ] [ convert-loop-tail-call ] }
{ [ dup word-tail-call? ] [ convert-word-tail-call ] }
- { [ dup fixnum-tail-call? ] [ convert-fixnum-tail-call ] }
[ drop ]
} cond
] [ drop ] if ;
M: ##shr-imm convert-two-operand* convert-two-operand/integer ;
M: ##sar-imm convert-two-operand* convert-two-operand/integer ;
+M: ##fixnum-overflow convert-two-operand* convert-two-operand/integer ;
+
M: ##add-float convert-two-operand* convert-two-operand/float ;
M: ##sub-float convert-two-operand* convert-two-operand/float ;
M: ##mul-float convert-two-operand* convert-two-operand/float ;
: emit-primitive ( node -- )
word>> ##call ##branch begin-basic-block ;
+: with-branch ( quot -- final-bb )
+ [
+ begin-basic-block
+ call
+ basic-block get dup [ ##branch ] when
+ ] with-scope ; inline
+
+: emit-conditional ( branches -- )
+ end-basic-block
+ begin-basic-block
+ basic-block get '[ [ _ swap successors>> push ] when* ] each ;
+
: back-edge? ( from to -- ? )
[ number>> ] bi@ >= ;
M: ##not generate-insn dst/src %not ;
M: ##log2 generate-insn dst/src %log2 ;
-: src1/src2 ( insn -- src1 src2 )
- [ src1>> register ] [ src2>> register ] bi ; inline
-
-: src1/src2/temp1/temp2 ( insn -- src1 src2 temp1 temp2 )
- [ src1/src2 ] [ temp1>> register ] [ temp2>> register ] tri ; inline
-
-M: ##fixnum-add generate-insn src1/src2 %fixnum-add ;
-M: ##fixnum-add-tail generate-insn src1/src2 %fixnum-add-tail ;
-M: ##fixnum-sub generate-insn src1/src2 %fixnum-sub ;
-M: ##fixnum-sub-tail generate-insn src1/src2 %fixnum-sub-tail ;
-M: ##fixnum-mul generate-insn src1/src2/temp1/temp2 %fixnum-mul ;
-M: ##fixnum-mul-tail generate-insn src1/src2/temp1/temp2 %fixnum-mul-tail ;
+: label/dst/src1/src2 ( insn -- label dst src1 src2 )
+ [ label>> lookup-label ] [ dst/src1/src2 ] bi ; inline
+
+M: _fixnum-add generate-insn label/dst/src1/src2 %fixnum-add ;
+M: _fixnum-sub generate-insn label/dst/src1/src2 %fixnum-sub ;
+M: _fixnum-mul generate-insn label/dst/src1/src2 %fixnum-mul ;
: dst/src/temp ( insn -- dst src temp )
[ dst/src ] [ temp>> register ] bi ; inline
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
compiler.tree.builder
compiler.tree.optimizer
compiler.tree.combinators
-compiler.tree.checker ;
+compiler.tree.checker
+compiler.tree.dead-code
+compiler.tree.modular-arithmetic ;
FROM: fry => _ ;
RENAME: _ match => __
IN: compiler.tree.debugger
: cleaned-up-tree ( quot -- nodes )
[
- check-optimizer? on
- build-tree optimize-tree
+ build-tree
+ analyze-recursive
+ normalize
+ propagate
+ cleanup
+ compute-def-use
+ remove-dead-code
+ compute-def-use
+ optimize-modular-arithmetic
] with-scope ;
: inlined? ( quot seq/word -- ? )
[ drop ]
} cond ;
+M: math-partial finalize-word
+ dup primitive? [ drop ] [ nip cached-expansion ] if ;
+
M: word finalize-word drop ;
M: #call finalize*
USING: kernel kernel.private tools.test math math.partial-dispatch
math.private accessors slots.private sequences strings sbufs
compiler.tree.builder
-compiler.tree.optimizer
+compiler.tree.normalization
compiler.tree.debugger
alien.accessors layouts combinators byte-arrays ;
: test-modular-arithmetic ( quot -- quot' )
- build-tree optimize-tree nodes>quot ;
+ cleaned-up-tree nodes>quot ;
[ [ >R >fixnum R> >fixnum fixnum+fast ] ]
[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test
HOOK: %not cpu ( dst src -- )
HOOK: %log2 cpu ( dst src -- )
-HOOK: %fixnum-add cpu ( src1 src2 -- )
-HOOK: %fixnum-add-tail cpu ( src1 src2 -- )
-HOOK: %fixnum-sub cpu ( src1 src2 -- )
-HOOK: %fixnum-sub-tail cpu ( src1 src2 -- )
-HOOK: %fixnum-mul cpu ( src1 src2 temp1 temp2 -- )
-HOOK: %fixnum-mul-tail cpu ( src1 src2 temp1 temp2 -- )
+HOOK: %fixnum-add cpu ( label dst src1 src2 -- )
+HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
+HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )
HOOK: %integer>bignum cpu ( dst src temp -- )
HOOK: %bignum>integer cpu ( dst src temp -- )
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
-M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ;
-
M: x86.32 return-struct-in-registers? ( c-type -- ? )
c-type
[ return-in-registers?>> ]
rc-absolute-cell rel-dlsym
R11 CALL ;
-M: x86.64 %alien-invoke-tail
- R11 0 MOV
- rc-absolute-cell rel-dlsym
- R11 JMP ;
-
M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
RBP RAX MOV ;
: ?MOV ( dst src -- )
2dup = [ 2drop ] [ MOV ] if ; inline
-:: move>args ( src1 src2 -- )
- {
- { [ src1 param-reg-2 = ] [ param-reg-1 src2 ?MOV param-reg-1 param-reg-2 XCHG ] }
- { [ src1 param-reg-1 = ] [ param-reg-2 src2 ?MOV ] }
- { [ src2 param-reg-1 = ] [ param-reg-2 src1 ?MOV param-reg-1 param-reg-2 XCHG ] }
- { [ src2 param-reg-2 = ] [ param-reg-1 src1 ?MOV ] }
- [
- param-reg-1 src1 MOV
- param-reg-2 src2 MOV
- ]
- } cond ;
-
-HOOK: %alien-invoke-tail cpu ( func dll -- )
-
-:: overflow-template ( src1 src2 insn inverse func -- )
- <label> "no-overflow" set
+:: overflow-template ( label dst src1 src2 insn -- )
src1 src2 insn call
- ds-reg [] src1 MOV
- "no-overflow" get JNO
- src1 src2 inverse call
- src1 src2 move>args
- %prepare-alien-invoke
- func f %alien-invoke
- "no-overflow" resolve-label ; inline
+ label JO ; inline
-:: overflow-template-tail ( src1 src2 insn inverse func -- )
- <label> "no-overflow" set
- src1 src2 insn call
- "no-overflow" get JNO
- src1 src2 inverse call
- src1 src2 move>args
- %prepare-alien-invoke
- func f %alien-invoke-tail
- "no-overflow" resolve-label
- ds-reg [] src1 MOV
- 0 RET ; inline
-
-M: x86 %fixnum-add ( src1 src2 -- )
- [ ADD ] [ SUB ] "overflow_fixnum_add" overflow-template ;
-
-M: x86 %fixnum-add-tail ( src1 src2 -- )
- [ ADD ] [ SUB ] "overflow_fixnum_add" overflow-template-tail ;
-
-M: x86 %fixnum-sub ( src1 src2 -- )
- [ SUB ] [ ADD ] "overflow_fixnum_subtract" overflow-template ;
-
-M: x86 %fixnum-sub-tail ( src1 src2 -- )
- [ SUB ] [ ADD ] "overflow_fixnum_subtract" overflow-template-tail ;
-
-M:: x86 %fixnum-mul ( src1 src2 temp1 temp2 -- )
- "no-overflow" define-label
- temp1 src1 MOV
- temp1 tag-bits get SAR
- src2 temp1 IMUL2
- ds-reg [] temp1 MOV
- "no-overflow" get JNO
- src1 src2 move>args
- param-reg-1 tag-bits get SAR
- param-reg-2 tag-bits get SAR
- %prepare-alien-invoke
- "overflow_fixnum_multiply" f %alien-invoke
- "no-overflow" resolve-label ;
-
-M:: x86 %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
- "overflow" define-label
- temp1 src1 MOV
- temp1 tag-bits get SAR
- src2 temp1 IMUL2
- "overflow" get JO
- ds-reg [] temp1 MOV
- 0 RET
- "overflow" resolve-label
- src1 src2 move>args
- param-reg-1 tag-bits get SAR
- param-reg-2 tag-bits get SAR
- %prepare-alien-invoke
- "overflow_fixnum_multiply" f %alien-invoke-tail ;
+M: x86 %fixnum-add ( label dst src1 src2 -- )
+ [ ADD ] overflow-template ;
+
+M: x86 %fixnum-sub ( label dst src1 src2 -- )
+ [ SUB ] overflow-template ;
+
+M: x86 %fixnum-mul ( label dst src1 src2 -- )
+ [ swap IMUL2 ] overflow-template ;
: bignum@ ( reg n -- op )
cells bignum tag-number - [+] ; inline
projects / factor.git / commitdiff