steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Overflowing fixnum intrinsics now expand into several CFG nodes. This speeds up the common case since only the uncommon case is now a stack syncpoint

db4
Slava Pestov 2009-07-16 18:29:40 -05:00
parent 685e32b091
commit e76dce8aff
25 changed files with 143 additions and 404 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor
View File

@ -1,6 +1,6 @@
USING: accessors assocs compiler.cfg USING: accessors assocs compiler.cfg
compiler.cfg.branch-splitting compiler.cfg.debugger 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 ; tools.test namespaces sequences vectors ;
IN: compiler.cfg.branch-splitting.tests IN: compiler.cfg.branch-splitting.tests
@ -20,31 +20,31 @@ IN: compiler.cfg.branch-splitting.tests
: test-branch-splitting ( -- ) : test-branch-splitting ( -- )
cfg new 0 get >>entry check-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-diamond
[ ] [ test-branch-splitting ] unit-test [ ] [ 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 0 get 1 get 2 get V{ } 2sequence >>successors drop
@ -54,15 +54,15 @@ V{ } 5 test-bb
[ ] [ test-branch-splitting ] unit-test [ ] [ 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 0 get 1 get 2 get V{ } 2sequence >>successors drop
@ -72,11 +72,11 @@ V{ } 4 test-bb
[ ] [ test-branch-splitting ] unit-test [ ] [ 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 0 get 1 get 2 get V{ } 2sequence >>successors drop

4
basis/compiler/cfg/branch-splitting/branch-splitting.factor
View File

@ -63,7 +63,9 @@ IN: compiler.cfg.branch-splitting
UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ; UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
: split-instructions? ( insns -- ? ) : split-instructions? ( insns -- ? )
[ irrelevant? not ] count 5 <= ; [ [ irrelevant? not ] count 5 <= ]
[ last ##fixnum-overflow? not ]
bi and ;
: split-branch? ( bb -- ? ) : split-branch? ( bb -- ? )
{ {

8
basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences USING: namespaces accessors math.order assocs kernel sequences
combinators make classes words cpu.architecture combinators make classes words cpu.architecture
@ -36,12 +36,6 @@ M: insn compute-stack-frame*
] when ; ] when ;
\ _spill t frame-required? set-word-prop \ _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 -- ) : compute-stack-frame ( insns -- )
frame-required? off frame-required? off

11
basis/compiler/cfg/builder/builder.factor
View File

@ -98,17 +98,10 @@ M: #recursive emit-node
! #if ! #if
: emit-branch ( obj -- final-bb ) : emit-branch ( obj -- final-bb )
[ [ emit-nodes ] with-branch ;
begin-basic-block
emit-nodes
basic-block get dup [ ##branch ] when
] with-scope ;
: emit-if ( node -- ) : emit-if ( node -- )
children>> [ emit-branch ] map children>> [ emit-branch ] map emit-conditional ;
end-basic-block
begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each ;
: ##branch-t ( vreg -- ) : ##branch-t ( vreg -- )
\ f tag-number cc/= ##compare-imm-branch ; \ f tag-number cc/= ##compare-imm-branch ;

6
basis/compiler/cfg/checker/checker.factor
View File

@ -16,9 +16,9 @@ ERROR: last-insn-not-a-jump insn ;
[ ##return? ] [ ##return? ]
[ ##callback-return? ] [ ##callback-return? ]
[ ##jump? ] [ ##jump? ]
[ ##fixnum-add-tail? ] [ ##fixnum-add? ]
[ ##fixnum-sub-tail? ] [ ##fixnum-sub? ]
[ ##fixnum-mul-tail? ] [ ##fixnum-mul? ]
[ ##no-tco? ] [ ##no-tco? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ; } 1|| [ drop ] [ last-insn-not-a-jump ] if ;

3
basis/compiler/cfg/def-use/def-use.factor
View File

@ -8,6 +8,7 @@ GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq )
M: ##flushable defs-vregs dst>> 1array ; M: ##flushable defs-vregs dst>> 1array ;
M: ##fixnum-overflow defs-vregs dst>> 1array ;
M: insn defs-vregs drop f ; M: insn defs-vregs drop f ;
M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ; M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
@ -21,8 +22,6 @@ M: ##set-string-nth-fast temp-vregs temp>> 1array ;
M: ##compare temp-vregs temp>> 1array ; M: ##compare temp-vregs temp>> 1array ;
M: ##compare-imm temp-vregs temp>> 1array ; M: ##compare-imm temp-vregs temp>> 1array ;
M: ##compare-float 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: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: _dispatch temp-vregs temp>> 1array ; M: _dispatch temp-vregs temp>> 1array ;
M: insn temp-vregs drop f ; M: insn temp-vregs drop f ;

4
basis/compiler/cfg/hats/hats.factor
View File

@ -73,5 +73,7 @@ IN: compiler.cfg.hats
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-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 : ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline

30
basis/compiler/cfg/instructions/instructions.factor
View File

@ -92,15 +92,6 @@ INSN: ##sar-imm < ##binary-imm ;
INSN: ##not < ##unary ; INSN: ##not < ##unary ;
INSN: ##log2 < ##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 : ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline : ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
@ -181,6 +172,7 @@ INSN: ##loop-entry ;
INSN: ##phi < ##pure inputs ; INSN: ##phi < ##pure inputs ;
! Conditionals
TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ; TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
INSN: ##compare-branch < ##conditional-branch ; INSN: ##compare-branch < ##conditional-branch ;
@ -192,6 +184,12 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
INSN: ##compare-float-branch < ##conditional-branch ; INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc temp ; 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 ; INSN: ##gc { temp1 vreg } { temp2 vreg } live-values ;
! Instructions used by machine IR only. ! Instructions used by machine IR only.
@ -212,6 +210,12 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
INSN: _compare-float-branch < _conditional-branch ; 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 TUPLE: spill-slot n ; C: <spill-slot> spill-slot
INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ; INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
@ -227,10 +231,7 @@ INSN: _spill-counts counts ;
UNION: poison-insn UNION: poison-insn
##jump ##jump
##return ##return
##callback-return ##callback-return ;
##fixnum-mul-tail
##fixnum-add-tail
##fixnum-sub-tail ;
! Instructions that kill all live vregs ! Instructions that kill all live vregs
UNION: kill-vreg-insn UNION: kill-vreg-insn
@ -239,9 +240,6 @@ UNION: kill-vreg-insn
##call ##call
##prologue ##prologue
##epilogue ##epilogue
##fixnum-mul
##fixnum-add
##fixnum-sub
##alien-invoke ##alien-invoke
##alien-indirect ##alien-indirect
##alien-callback ; ##alien-callback ;

30
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors layouts kernel math namespaces USING: sequences accessors layouts kernel math namespaces
combinators fry combinators fry arrays
compiler.tree.propagation.info compiler.tree.propagation.info
compiler.cfg.hats compiler.cfg.hats
compiler.cfg.stacks compiler.cfg.stacks
@ -54,6 +54,28 @@ IN: compiler.cfg.intrinsics.fixnum
: emit-fixnum>bignum ( -- ) : emit-fixnum>bignum ( -- )
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ; ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
: emit-fixnum-overflow-op ( quot -- next ) : emit-no-overflow-case ( dst -- final-bb )
[ 2inputs 1 ##inc-d ] dip call ##branch [ -2 ##inc-d ds-push ] with-branch ;
begin-basic-block ; inline
: 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 ;

6
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -100,9 +100,9 @@ IN: compiler.cfg.intrinsics
{ \ kernel.private:tag [ drop emit-tag ] } { \ kernel.private:tag [ drop emit-tag ] }
{ \ kernel.private:getenv [ emit-getenv ] } { \ kernel.private:getenv [ emit-getenv ] }
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? ] } { \ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] emit-fixnum-overflow-op ] } { \ math.private:fixnum+ [ drop emit-fixnum+ ] }
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] emit-fixnum-overflow-op ] } { \ math.private:fixnum- [ drop emit-fixnum- ] }
{ \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] emit-fixnum-overflow-op ] } { \ math.private:fixnum* [ drop emit-fixnum* ] }
{ \ math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] } { \ math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
{ \ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] } { \ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] } { \ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }

207
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -2159,12 +2159,7 @@ V{
T{ ##replace { src V int-regs 85 } { loc D 1 } } 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 89 } { loc D 4 } }
T{ ##replace { src V int-regs 96 } { loc R 0 } } T{ ##replace { src V int-regs 96 } { loc R 0 } }
T{ ##fixnum-mul T{ ##replace { src V int-regs 129 } { loc R 0 } }
{ src1 V int-regs 128 }
{ src2 V int-regs 129 }
{ temp1 V int-regs 132 }
{ temp2 V int-regs 133 }
}
T{ ##branch } T{ ##branch }
} 2 test-bb } 2 test-bb
@ -2255,206 +2250,6 @@ V{
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test [ ] [ { 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 ! Fencepost error in assignment pass
V{ T{ ##branch } } 0 test-bb V{ T{ ##branch } } 0 test-bb

17
basis/compiler/cfg/linearization/linearization.factor
View File

@ -31,8 +31,10 @@ M: insn linearize-insn , drop ;
M: ##branch linearize-insn M: ##branch linearize-insn
drop dup successors>> first emit-branch ; 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 ) : (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
[ dup successors>> first2 ] [ dup successors ]
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc ) : binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
@ -52,6 +54,19 @@ M: ##compare-imm-branch linearize-insn
M: ##compare-float-branch linearize-insn M: ##compare-float-branch linearize-insn
[ binary-conditional _compare-float-branch ] with-regs emit-branch ; [ 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 M: ##dispatch linearize-insn
swap swap
[ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ] [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]

10
basis/compiler/cfg/renaming/renaming.factor
View File

@ -136,16 +136,6 @@ M: ##compare-imm fresh-insn-temps
M: ##compare-float fresh-insn-temps M: ##compare-float fresh-insn-temps
[ fresh-vreg ] change-temp drop ; [ 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 M: ##gc fresh-insn-temps
[ fresh-vreg ] change-temp1 [ fresh-vreg ] change-temp1
[ fresh-vreg ] change-temp2 [ fresh-vreg ] change-temp2

3
basis/compiler/cfg/stack-analysis/stack-analysis.factor
View File

@ -61,7 +61,8 @@ UNION: sync-if-back-edge
##conditional-branch ##conditional-branch
##compare-imm-branch ##compare-imm-branch
##dispatch ##dispatch
##loop-entry ; ##loop-entry
##fixnum-overflow ;
: sync-state? ( -- ? ) : sync-state? ( -- ? )
basic-block get successors>> basic-block get successors>>

17
basis/compiler/cfg/tco/tco.factor
View File

@ -53,28 +53,11 @@ IN: compiler.cfg.tco
[ [ cfg get entry>> successors>> first ] dip successors>> push ] [ [ cfg get entry>> successors>> first ] dip successors>> push ]
tri ; 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 -- ) : optimize-tail-call ( bb -- )
dup tail-call? [ dup tail-call? [
{ {
{ [ dup loop-tail-call? ] [ convert-loop-tail-call ] } { [ dup loop-tail-call? ] [ convert-loop-tail-call ] }
{ [ dup word-tail-call? ] [ convert-word-tail-call ] } { [ dup word-tail-call? ] [ convert-word-tail-call ] }
{ [ dup fixnum-tail-call? ] [ convert-fixnum-tail-call ] }
[ drop ] [ drop ]
} cond } cond
] [ drop ] if ; ] [ drop ] if ;

2
basis/compiler/cfg/two-operand/two-operand.factor
View File

@ -44,6 +44,8 @@ M: ##shl-imm convert-two-operand* convert-two-operand/integer ;
M: ##shr-imm convert-two-operand* convert-two-operand/integer ; M: ##shr-imm convert-two-operand* convert-two-operand/integer ;
M: ##sar-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: ##add-float convert-two-operand* convert-two-operand/float ;
M: ##sub-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 ; M: ##mul-float convert-two-operand* convert-two-operand/float ;

12
basis/compiler/cfg/utilities/utilities.factor
View File

@ -36,6 +36,18 @@ IN: compiler.cfg.utilities
: emit-primitive ( node -- ) : emit-primitive ( node -- )
word>> ##call ##branch begin-basic-block ; 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 -- ? ) : back-edge? ( from to -- ? )
[ number>> ] bi@ >= ; [ number>> ] bi@ >= ;

16
basis/compiler/codegen/codegen.factor
View File

@ -171,18 +171,12 @@ M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
M: ##not generate-insn dst/src %not ; M: ##not generate-insn dst/src %not ;
M: ##log2 generate-insn dst/src %log2 ; M: ##log2 generate-insn dst/src %log2 ;
: src1/src2 ( insn -- src1 src2 ) : label/dst/src1/src2 ( insn -- label dst src1 src2 )
[ src1>> register ] [ src2>> register ] bi ; inline [ label>> lookup-label ] [ dst/src1/src2 ] bi ; inline
: src1/src2/temp1/temp2 ( insn -- src1 src2 temp1 temp2 ) M: _fixnum-add generate-insn label/dst/src1/src2 %fixnum-add ;
[ src1/src2 ] [ temp1>> register ] [ temp2>> register ] tri ; inline M: _fixnum-sub generate-insn label/dst/src1/src2 %fixnum-sub ;
M: _fixnum-mul generate-insn label/dst/src1/src2 %fixnum-mul ;
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 ;
: dst/src/temp ( insn -- dst src temp ) : dst/src/temp ( insn -- dst src temp )
[ dst/src ] [ temp>> register ] bi ; inline [ dst/src ] [ temp>> register ] bi ; inline

17
basis/compiler/tree/debugger/debugger.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs match fry accessors namespaces make effects USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays sequences sequences.private quotations generic macros arrays
@ -15,7 +15,9 @@ compiler.tree.def-use
compiler.tree.builder compiler.tree.builder
compiler.tree.optimizer compiler.tree.optimizer
compiler.tree.combinators compiler.tree.combinators
compiler.tree.checker ; compiler.tree.checker
compiler.tree.dead-code
compiler.tree.modular-arithmetic ;
FROM: fry => _ ; FROM: fry => _ ;
RENAME: _ match => __ RENAME: _ match => __
IN: compiler.tree.debugger IN: compiler.tree.debugger
@ -201,8 +203,15 @@ SYMBOL: node-count
: cleaned-up-tree ( quot -- nodes ) : cleaned-up-tree ( quot -- nodes )
[ [
check-optimizer? on build-tree
build-tree optimize-tree analyze-recursive
normalize
propagate
cleanup
compute-def-use
remove-dead-code
compute-def-use
optimize-modular-arithmetic
] with-scope ; ] with-scope ;
: inlined? ( quot seq/word -- ? ) : inlined? ( quot seq/word -- ? )

3
basis/compiler/tree/finalization/finalization.factor
View File

@ -46,6 +46,9 @@ M: predicate finalize-word
[ drop ] [ drop ]
} cond ; } cond ;
M: math-partial finalize-word
dup primitive? [ drop ] [ nip cached-expansion ] if ;
M: word finalize-word drop ; M: word finalize-word drop ;
M: #call finalize* M: #call finalize*

4
basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor
View File

@ -4,12 +4,12 @@ IN: compiler.tree.modular-arithmetic.tests
USING: kernel kernel.private tools.test math math.partial-dispatch USING: kernel kernel.private tools.test math math.partial-dispatch
math.private accessors slots.private sequences strings sbufs math.private accessors slots.private sequences strings sbufs
compiler.tree.builder compiler.tree.builder
compiler.tree.optimizer compiler.tree.normalization
compiler.tree.debugger compiler.tree.debugger
alien.accessors layouts combinators byte-arrays ; alien.accessors layouts combinators byte-arrays ;
: test-modular-arithmetic ( quot -- quot' ) : test-modular-arithmetic ( quot -- quot' )
build-tree optimize-tree nodes>quot ; cleaned-up-tree nodes>quot ;
[ [ >R >fixnum R> >fixnum fixnum+fast ] ] [ [ >R >fixnum R> >fixnum fixnum+fast ] ]
[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test [ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test

9
basis/cpu/architecture/architecture.factor
View File

@ -82,12 +82,9 @@ HOOK: %sar-imm cpu ( dst src1 src2 -- )
HOOK: %not cpu ( dst src -- ) HOOK: %not cpu ( dst src -- )
HOOK: %log2 cpu ( dst src -- ) HOOK: %log2 cpu ( dst src -- )
HOOK: %fixnum-add cpu ( src1 src2 -- ) HOOK: %fixnum-add cpu ( label dst src1 src2 -- )
HOOK: %fixnum-add-tail cpu ( src1 src2 -- ) HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
HOOK: %fixnum-sub cpu ( src1 src2 -- ) HOOK: %fixnum-mul cpu ( label dst 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: %integer>bignum cpu ( dst src temp -- ) HOOK: %integer>bignum cpu ( dst src temp -- )
HOOK: %bignum>integer cpu ( dst src temp -- ) HOOK: %bignum>integer cpu ( dst src temp -- )

2
basis/cpu/x86/32/32.factor
View File

@ -51,8 +51,6 @@ M: x86.32 reserved-area-size 0 ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; 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 -- ? ) M: x86.32 return-struct-in-registers? ( c-type -- ? )
c-type c-type
[ return-in-registers?>> ] [ return-in-registers?>> ]

5
basis/cpu/x86/64/64.factor
View File

@ -167,11 +167,6 @@ M: x86.64 %alien-invoke
rc-absolute-cell rel-dlsym rc-absolute-cell rel-dlsym
R11 CALL ; R11 CALL ;
M: x86.64 %alien-invoke-tail
R11 0 MOV
rc-absolute-cell rel-dlsym
R11 JMP ;
M: x86.64 %prepare-alien-indirect ( -- ) M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke "unbox_alien" f %alien-invoke
RBP RAX MOV ; RBP RAX MOV ;

81
basis/cpu/x86/x86.factor
View File

@ -129,83 +129,18 @@ M: x86 %log2 BSR ;
: ?MOV ( dst src -- ) : ?MOV ( dst src -- )
2dup = [ 2drop ] [ MOV ] if ; inline 2dup = [ 2drop ] [ MOV ] if ; inline
:: move>args ( src1 src2 -- ) :: overflow-template ( label dst src1 src2 insn -- )
{
{ [ 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
src1 src2 insn call src1 src2 insn call
ds-reg [] src1 MOV label JO ; inline
"no-overflow" get JNO
src1 src2 inverse call
src1 src2 move>args
%prepare-alien-invoke
func f %alien-invoke
"no-overflow" resolve-label ; inline
:: overflow-template-tail ( src1 src2 insn inverse func -- ) M: x86 %fixnum-add ( label dst src1 src2 -- )
<label> "no-overflow" set [ ADD ] overflow-template ;
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 -- ) M: x86 %fixnum-sub ( label dst src1 src2 -- )
[ ADD ] [ SUB ] "overflow_fixnum_add" overflow-template ; [ SUB ] overflow-template ;
M: x86 %fixnum-add-tail ( src1 src2 -- ) M: x86 %fixnum-mul ( label dst src1 src2 -- )
[ ADD ] [ SUB ] "overflow_fixnum_add" overflow-template-tail ; [ swap IMUL2 ] overflow-template ;
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 ;
: bignum@ ( reg n -- op ) : bignum@ ( reg n -- op )
cells bignum tag-number - [+] ; inline cells bignum tag-number - [+] ; inline