M: ##call compute-stack-frame* drop frame-required? on ;
-M: ##gc compute-stack-frame*
+M: ##call-gc compute-stack-frame*
+ drop
frame-required? on
- stack-frame new
- swap tagged-values>> length cells >>gc-root-size
- t >>calls-vm?
- request-stack-frame ;
+ stack-frame new t >>calls-vm? request-stack-frame ;
M: _spill-area-size compute-stack-frame*
n>> stack-frame get (>>spill-area-size) ;
frame-required? on
] when ;
+! PowerPC backend sets frame-required? for ##integer>float!
\ _spill t frame-required? set-word-prop
\ ##unary-float-function t frame-required? set-word-prop
\ ##binary-float-function t frame-required? set-word-prop
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math vectors arrays accessors namespaces ;
IN: compiler.cfg
number
{ instructions vector }
{ successors vector }
-{ predecessors vector } ;
+{ predecessors vector }
+{ unlikely? boolean } ;
: <basic-block> ( -- bb )
basic-block new
dup instructions>> last {
[ ##branch? ]
[ ##dispatch? ]
- [ ##compare-branch? ]
- [ ##compare-imm-branch? ]
- [ ##compare-integer-branch? ]
- [ ##compare-integer-imm-branch? ]
- [ ##compare-float-ordered-branch? ]
- [ ##compare-float-unordered-branch? ]
- [ ##fixnum-add? ]
- [ ##fixnum-sub? ]
- [ ##fixnum-mul? ]
+ [ conditional-branch-insn? ]
[ ##no-tco? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs math.order sequences ;
IN: compiler.cfg.comparisons
SYMBOLS:
vcc-all vcc-notall vcc-any vcc-none ;
+SYMBOLS: cc-o cc/o ;
+
: negate-cc ( cc -- cc' )
H{
{ cc< cc/< }
{ cc/= cc= }
{ cc/<> cc<> }
{ cc/<>= cc<>= }
+ { cc-o cc/o }
+ { cc/o cc-o }
} at ;
: negate-vcc ( cc -- cc' )
-! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs arrays classes combinators
compiler.units fry generalizations generic kernel locals
M: ##phi uses-vregs inputs>> values ;
+M: _conditional-branch defs-vreg insn>> defs-vreg ;
+
+M: _conditional-branch uses-vregs insn>> uses-vregs ;
+
<PRIVATE
: slot-array-quot ( slots -- quot )
[
insn-classes get
[ [ define-defs-vreg-method ] each ]
- [ { ##phi } diff [ define-uses-vregs-method ] each ]
+ [ { ##phi _conditional-branch } diff [ define-uses-vregs-method ] each ]
[ [ define-temp-vregs-method ] each ]
tri
] with-compilation-unit
-USING: compiler.cfg.gc-checks compiler.cfg.debugger
+USING: arrays compiler.cfg.gc-checks
+compiler.cfg.gc-checks.private compiler.cfg.debugger
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
-compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
-namespaces accessors sequences ;
+compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture
+tools.test kernel vectors namespaces accessors sequences alien
+memory classes make combinators.short-circuit byte-arrays ;
IN: compiler.cfg.gc-checks.tests
: test-gc-checks ( -- )
H{ } clone representations set
- cfg new 0 get >>entry
- insert-gc-checks
- drop ;
+ cfg new 0 get >>entry cfg set ;
V{
T{ ##inc-d f 3 }
[ ] [ test-gc-checks ] unit-test
-[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
+[ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
+
+[ ] [ 1 get allocation-size 123 <alien> size assert= ] unit-test
+
+2 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##load-tagged f 3 0 }
+ T{ ##replace f 3 D 0 }
+ T{ ##replace f 3 R 3 }
+ }
+] [ [ { D 0 R 3 } wipe-locs ] V{ } make ] unit-test
+
+: gc-check? ( bb -- ? )
+ instructions>>
+ {
+ [ length 1 = ]
+ [ first ##check-nursery-branch? ]
+ } 1&& ;
+
+[ t ] [ 100 <gc-check> gc-check? ] unit-test
+
+2 \ vreg-counter set-global
+
+[
+ V{
+ T{ ##save-context f 3 4 }
+ T{ ##load-tagged f 5 0 }
+ T{ ##replace f 5 D 0 }
+ T{ ##replace f 5 R 3 }
+ T{ ##call-gc f { 0 1 2 } }
+ T{ ##branch }
+ }
+]
+[
+ { D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
+] unit-test
+
+30 \ vreg-counter set-global
+
+V{
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##branch }
+} 4 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get needs-predecessors drop ] unit-test
+
+[ ] [ 31337 { D 1 R 2 } { 10 20 } 3 get (insert-gc-check) ] unit-test
+
+[ t ] [ 1 get successors>> first gc-check? ] unit-test
+
+[ t ] [ 2 get successors>> first gc-check? ] unit-test
+
+[ t ] [ 3 get predecessors>> first gc-check? ] unit-test
+
+30 \ vreg-counter set-global
+
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f 2 D 0 }
+ T{ ##inc-d f 3 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##allot f 1 64 byte-array }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##replace f 2 D 1 }
+ T{ ##branch }
+} 4 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 5 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 5 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+H{
+ { 2 tagged-rep }
+} representations set
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+[ 2 ] [ 2 get predecessors>> length ] unit-test
+
+[ t ] [ 1 get successors>> first gc-check? ] unit-test
+
+[ 64 ] [ 1 get successors>> first instructions>> first size>> ] unit-test
+
+[ t ] [ 2 get predecessors>> first gc-check? ] unit-test
+
+[
+ V{
+ T{ ##save-context f 33 34 }
+ T{ ##load-tagged f 35 0 }
+ T{ ##replace f 35 D 0 }
+ T{ ##replace f 35 D 1 }
+ T{ ##replace f 35 D 2 }
+ T{ ##call-gc f { 2 } }
+ T{ ##branch }
+ }
+] [ 2 get predecessors>> second instructions>> ] unit-test
+
+! Don't forget to invalidate RPO after inserting basic blocks!
+[ 8 ] [ cfg get reverse-post-order length ] unit-test
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs fry math
-cpu.architecture layouts namespaces
+USING: accessors assocs combinators fry kernel layouts locals
+math make namespaces sequences cpu.architecture
+compiler.cfg
compiler.cfg.rpo
+compiler.cfg.hats
compiler.cfg.registers
+compiler.cfg.utilities
+compiler.cfg.comparisons
compiler.cfg.instructions
+compiler.cfg.predecessors
+compiler.cfg.liveness
+compiler.cfg.liveness.ssa
compiler.cfg.stacks.uninitialized ;
IN: compiler.cfg.gc-checks
-! Garbage collection check insertion. This pass runs after representation
-! selection, so it must keep track of representations.
+<PRIVATE
+
+! Garbage collection check insertion. This pass runs after
+! representation selection, since it needs to know which vregs
+! can contain tagged pointers.
: insert-gc-check? ( bb -- ? )
instructions>> [ ##allocation? ] any? ;
: blocks-with-gc ( cfg -- bbs )
post-order [ insert-gc-check? ] filter ;
+! A GC check for bb consists of two new basic blocks, gc-check
+! and gc-call:
+!
+! gc-check
+! / \
+! | gc-call
+! \ /
+! bb
+
+: <gc-check> ( size -- bb )
+ [ <basic-block> ] dip
+ [
+ cc<= int-rep next-vreg-rep int-rep next-vreg-rep
+ ##check-nursery-branch
+ ] V{ } make >>instructions ;
+
+: wipe-locs ( uninitialized-locs -- )
+ '[
+ int-rep next-vreg-rep
+ [ 0 ##load-tagged ]
+ [ '[ [ _ ] dip ##replace ] each ] bi
+ ] unless-empty ;
+
+: <gc-call> ( uninitialized-locs gc-roots -- bb )
+ [ <basic-block> ] 2dip
+ [ [ wipe-locs ] [ ##call-gc ] bi* ##branch ] V{ } make
+ >>instructions t >>unlikely? ;
+
+:: insert-guard ( check body bb -- )
+ bb predecessors>> check (>>predecessors)
+ V{ bb body } check (>>successors)
+
+ V{ check } body (>>predecessors)
+ V{ bb } body (>>successors)
+
+ V{ check body } bb (>>predecessors)
+
+ check predecessors>> [ bb check update-successors ] each ;
+
+: (insert-gc-check) ( size uninitialized-locs gc-roots bb -- )
+ [ [ <gc-check> ] 2dip <gc-call> ] dip insert-guard ;
+
GENERIC: allocation-size* ( insn -- n )
M: ##allot allocation-size* size>> ;
[ ##allocation? ] filter
[ allocation-size* data-alignment get align ] map-sum ;
+: live-tagged ( bb -- vregs )
+ live-in keys [ rep-of tagged-rep? ] filter ;
+
: insert-gc-check ( bb -- )
- dup dup '[
- tagged-rep next-vreg-rep
- tagged-rep next-vreg-rep
- _ allocation-size
- f
- f
- _ uninitialized-locs
- \ ##gc new-insn
- prefix
- ] change-instructions drop ;
+ {
+ [ allocation-size ]
+ [ uninitialized-locs ]
+ [ live-tagged ]
+ [ ]
+ } cleave
+ (insert-gc-check) ;
+
+PRIVATE>
: insert-gc-checks ( cfg -- cfg' )
dup blocks-with-gc [
- over compute-uninitialized-sets
+ [
+ needs-predecessors
+ dup compute-ssa-live-sets
+ dup compute-uninitialized-sets
+ ] dip
[ insert-gc-check ] each
+ cfg-changed
] unless-empty ;
! Overflowing arithmetic
INSN: ##fixnum-add
def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+use: src1/tagged-rep src2/tagged-rep
+literal: cc ;
INSN: ##fixnum-sub
def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+use: src1/tagged-rep src2/tagged-rep
+literal: cc ;
INSN: ##fixnum-mul
def: dst/tagged-rep
-use: src1/tagged-rep src2/int-rep ;
-
-INSN: ##gc
-temp: temp1/int-rep temp2/int-rep
-literal: size data-values tagged-values uninitialized-locs ;
+use: src1/tagged-rep src2/int-rep
+literal: cc ;
INSN: ##save-context
temp: temp1/int-rep temp2/int-rep ;
+! GC checks
+INSN: ##check-nursery-branch
+literal: size cc
+temp: temp1/int-rep temp2/int-rep ;
+
+INSN: ##call-gc
+literal: gc-roots ;
+
! Instructions used by machine IR only.
INSN: _prologue
literal: stack-frame ;
INSN: _loop-entry ;
-INSN: _dispatch
-use: src
-temp: temp ;
-
INSN: _dispatch-label
literal: label ;
-INSN: _compare-branch
-literal: label
-use: src1 src2
-literal: cc ;
-
-INSN: _compare-imm-branch
-literal: label
-use: src1
-literal: src2 cc ;
-
-INSN: _compare-float-unordered-branch
-literal: label
-use: src1 src2
-literal: cc ;
-
-INSN: _compare-float-ordered-branch
-literal: label
-use: src1 src2
-literal: cc ;
-
-! Overflowing arithmetic
-INSN: _fixnum-add
-literal: label
-def: dst
-use: src1 src2 ;
-
-INSN: _fixnum-sub
-literal: label
-def: dst
-use: src1 src2 ;
-
-INSN: _fixnum-mul
-literal: label
-def: dst
-use: src1 src2 ;
+INSN: _conditional-branch
+literal: label insn ;
TUPLE: spill-slot { n integer } ;
C: <spill-slot> spill-slot
INSN: _spill-area-size
literal: n ;
-! For GC check insertion
UNION: ##allocation
##allot
##box-alien
##box-displaced-alien ;
+UNION: conditional-branch-insn
+##compare-branch
+##compare-imm-branch
+##compare-integer-branch
+##compare-integer-imm-branch
+##compare-float-ordered-branch
+##compare-float-unordered-branch
+##test-vector-branch
+##check-nursery-branch
+##fixnum-add
+##fixnum-sub
+##fixnum-mul ;
+
! For alias analysis
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
-! Instructions that kill all live vregs but cannot trigger GC
-UNION: partial-sync-insn
+! Instructions that clobber registers
+UNION: clobber-insn
+##call-gc
##unary-float-function
##binary-float-function ;
namespaces combinators fry arrays
cpu.architecture
compiler.tree.propagation.info
+compiler.cfg
compiler.cfg.hats
compiler.cfg.stacks
compiler.cfg.instructions
: emit-fixnum-overflow-op ( quot word -- )
! Inputs to the final instruction need to be copied because
! of loc>vreg sync
- [ [ (2inputs) [ any-rep ^^copy ] bi@ ] dip call ] dip
+ [ [ (2inputs) [ any-rep ^^copy ] bi@ cc/o ] dip call ] dip
[ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
emit-conditional ; inline
: smallest-heap ( heap1 heap2 -- heap )
! If heap1 and heap2 have the same key, favors heap1.
- [ [ heap-peek nip ] bi@ <= ] most ;
+ {
+ { [ dup heap-empty? ] [ drop ] }
+ { [ over heap-empty? ] [ nip ] }
+ [ [ [ heap-peek nip ] bi@ <= ] most ]
+ } cond ;
: (allocate-registers) ( -- )
- {
- { [ unhandled-intervals get heap-empty? ] [ unhandled-sync-points get ] }
- { [ unhandled-sync-points get heap-empty? ] [ unhandled-intervals get ] }
- ! If a live interval begins at the same location as a sync point,
- ! process the sync point before the live interval. This ensures that the
- ! return value of C function calls doesn't get spilled and reloaded
- ! unnecessarily.
- [ unhandled-sync-points get unhandled-intervals get smallest-heap ]
- } cond dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
+ ! If a live interval begins at the same location as a sync point,
+ ! process the sync point before the live interval. This ensures that the
+ ! return value of C function calls doesn't get spilled and reloaded
+ ! unnecessarily.
+ unhandled-sync-points get unhandled-intervals get smallest-heap
+ dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
: finish-allocation ( -- )
active-intervals inactive-intervals
M: vreg-insn assign-registers-in-insn
[ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
-: trace-on-gc ( assoc -- assoc' )
- ! When a GC occurs, virtual registers which contain tagged data
- ! are traced by the GC. Outputs a sequence physical registers.
- [ drop rep-of tagged-rep eq? ] { } assoc-filter-as values ;
-
-: spill-on-gc? ( vreg reg -- ? )
- [ rep-of tagged-rep? not ] [ spill-slot? not ] bi* and ;
-
-: spill-on-gc ( assoc -- assoc' )
- ! When a GC occurs, virtual registers which contain untagged data,
- ! and are stored in physical registers, are saved to their spill
- ! slots. Outputs sequence of triples:
- ! - physical register
- ! - spill slot
- ! - representation
- [
- [
- 2dup spill-on-gc?
- [ swap [ rep-of ] [ vreg-spill-slot ] bi 3array , ] [ 2drop ] if
- ] assoc-each
- ] { } make ;
-
-: gc-root-offsets ( registers -- alist )
- ! Outputs a sequence of { offset register/spill-slot } pairs
- [ length iota [ cell * ] map ] keep zip ;
-
-M: ##gc assign-registers-in-insn
- ! Since ##gc is always the first instruction in a block, the set of
- ! values live at the ##gc is just live-in.
+M: ##call-gc assign-registers-in-insn
dup call-next-method
- basic-block get register-live-ins get at
- [ trace-on-gc gc-root-offsets >>tagged-values ] [ spill-on-gc >>data-values ] bi
- drop ;
+ [ [ vreg>reg ] map ] change-gc-roots drop ;
M: insn assign-registers-in-insn drop ;
[ 0 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
[ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
-
-V{
- T{ ##peek f 0 D 0 }
- T{ ##peek f 1 D 1 }
- T{ ##replace f 1 D 1 }
- T{ ##branch }
-} 0 test-bb
-
-V{
- T{ ##gc f 2 3 }
- T{ ##branch }
-} 1 test-bb
-
-V{
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 2 test-bb
-
-0 1 edge
-1 2 edge
-
-[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-
-[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test
-
-V{
- T{ ##peek f 0 D 0 }
- T{ ##peek f 1 D 1 }
- T{ ##compare-imm-branch f 1 5 cc= }
-} 0 test-bb
-
-V{
- T{ ##gc f 2 3 }
- T{ ##replace f 0 D 0 }
- T{ ##return }
-} 1 test-bb
-
-V{
- T{ ##return }
-} 2 test-bb
-
-0 { 1 2 } edges
-
-[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-
-[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test
[ dup temp-vregs [ handle-temp ] with each ]
tri ;
-M: partial-sync-insn compute-live-intervals*
+M: clobber-insn compute-live-intervals*
[ dup defs-vreg [ +use+ handle-output ] with when* ]
[ dup uses-vregs [ +memory+ handle-input ] with each ]
[ dup temp-vregs [ handle-temp ] with each ]
GENERIC: compute-sync-points* ( insn -- )
-M: partial-sync-insn compute-sync-points*
+M: clobber-insn compute-sync-points*
insn#>> <sync-point> sync-points get push ;
M: insn compute-sync-points* drop ;
[
{
T{ ##copy { src 1 } { dst 2 } { rep int-rep } }
+ T{ ##branch }
}
] [
{ { T{ location f 1 int-rep int-regs } T{ location f 2 int-rep int-regs } } }
{
T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 0 } } }
T{ _reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 1 } } }
+ T{ ##branch }
}
] [
{
{
T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
T{ _reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+ T{ ##branch }
}
] [
{
{
T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
T{ _reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+ T{ ##branch }
}
] [
{
T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
+ T{ ##branch }
}
{
T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
T{ _reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
+ T{ ##branch }
}
} member?
] unit-test
: mapping-instructions ( alist -- insns )
[ swap ] H{ } assoc-map-as
- [ temp [ swap >insn ] parallel-mapping ] { } make ;
+ [ temp [ swap >insn ] parallel-mapping ##branch ] { } make ;
: perform-mappings ( bb to mappings -- )
dup empty? [ 3drop ] [
- mapping-instructions insert-simple-basic-block
+ mapping-instructions insert-basic-block
cfg get cfg-changed drop
] if ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences namespaces make
combinators assocs arrays locals layouts hashtables
: number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ;
-! Convert CFG IR to machine IR.
GENERIC: linearize-insn ( basic-block insn -- )
-: linearize-basic-block ( bb -- )
- [ block-number _label ]
- [ dup instructions>> [ linearize-insn ] with each ]
- bi ;
-
M: insn linearize-insn , drop ;
: useless-branch? ( basic-block successor -- ? )
M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
-: successors ( bb -- first second ) successors>> first2 ; inline
-
-:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label etc... )
- bb insn
- conditional-quot
- [ drop dup successors>> second useless-branch? ] 2bi
- [ [ swap block-number ] n ndip ]
- [ [ block-number ] n ndip negate-cc-quot call ] if ; inline
-
-: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
- [ dup successors ]
- [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
-
-: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
- 3 [ (binary-conditional) ] [ negate-cc ] conditional ;
-
-: (test-vector-conditional) ( bb insn -- bb successor1 successor2 src1 temp rep vcc )
- [ dup successors ]
- [ { [ src1>> ] [ temp>> ] [ rep>> ] [ vcc>> ] } cleave ] bi* ; inline
-
-: test-vector-conditional ( bb insn -- bb successor label src1 temp rep vcc )
- 4 [ (test-vector-conditional) ] [ negate-vcc ] conditional ;
-
-M: ##compare-branch linearize-insn
- binary-conditional _compare-branch emit-branch ;
-
-M: ##compare-imm-branch linearize-insn
- binary-conditional _compare-imm-branch emit-branch ;
+GENERIC: negate-insn-cc ( insn -- )
-M: ##compare-integer-branch linearize-insn
- binary-conditional _compare-branch emit-branch ;
+M: conditional-branch-insn negate-insn-cc
+ [ negate-cc ] change-cc drop ;
-M: ##compare-integer-imm-branch linearize-insn
- binary-conditional _compare-imm-branch emit-branch ;
+M: ##test-vector-branch negate-insn-cc
+ [ negate-vcc ] change-vcc drop ;
-M: ##compare-float-ordered-branch linearize-insn
- binary-conditional _compare-float-ordered-branch emit-branch ;
-
-M: ##compare-float-unordered-branch linearize-insn
- binary-conditional _compare-float-unordered-branch emit-branch ;
-
-M: ##test-vector-branch linearize-insn
- test-vector-conditional _test-vector-branch emit-branch ;
-
-: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
- [ dup successors block-number ]
- [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
-
-M: ##fixnum-add linearize-insn
- overflow-conditional _fixnum-add emit-branch ;
-
-M: ##fixnum-sub linearize-insn
- overflow-conditional _fixnum-sub emit-branch ;
-
-M: ##fixnum-mul linearize-insn
- overflow-conditional _fixnum-mul emit-branch ;
+M:: conditional-branch-insn linearize-insn ( bb insn -- )
+ bb successors>> first2 :> ( first second )
+ bb second useless-branch?
+ [ bb second first ]
+ [ bb first second insn negate-insn-cc ] if
+ block-number insn _conditional-branch
+ emit-branch ;
M: ##dispatch linearize-insn
- swap
- [ [ src>> ] [ temp>> ] bi _dispatch ]
- [ successors>> [ block-number _dispatch-label ] each ]
- bi* ;
+ , successors>> [ block-number _dispatch-label ] each ;
+
+: linearize-basic-block ( bb -- )
+ [ block-number _label ]
+ [ dup instructions>> [ linearize-insn ] with each ]
+ bi ;
: linearize-basic-blocks ( cfg -- insns )
[
] { } make ;
PRIVATE>
-
+
: flatten-cfg ( cfg -- mr )
[ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
<mr> ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs deques dlists kernel make sorting
namespaces sequences combinators combinators.short-circuit
FROM: namespaces => set ;
IN: compiler.cfg.linearization.order
-! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
+! This is RPO except loops are rotated and unlikely blocks go
+! at the end. Based on SBCL's src/compiler/control.lisp
<PRIVATE
: (linearization-order) ( cfg -- bbs )
init-linearization-order
- [ work-list get [ process-block ] slurp-deque ] { } make ;
+ [ work-list get [ process-block ] slurp-deque ] { } make
+ ! [ unlikely?>> not ] partition append
+ ;
PRIVATE>
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces deques accessors sets sequences assocs fry
hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
[ predecessors>> add-to-work-list ] [ drop ] if
] [ drop ] if ;
-: compute-ssa-live-sets ( cfg -- cfg' )
+: compute-ssa-live-sets ( cfg -- )
needs-predecessors
<hashed-dlist> work-list set
H{ } clone live-ins set
H{ } clone phi-live-ins set
H{ } clone live-outs set
- dup post-order add-to-work-list
+ post-order add-to-work-list
work-list get [ liveness-step ] slurp-deque ;
: live-in? ( vreg bb -- ? ) live-in key? ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces accessors compiler.cfg
-compiler.cfg.linearization compiler.cfg.gc-checks
-compiler.cfg.save-contexts compiler.cfg.linear-scan
+compiler.cfg.linearization compiler.cfg.linear-scan
compiler.cfg.build-stack-frame ;
IN: compiler.cfg.mr
: build-mr ( cfg -- mr )
- insert-gc-checks
- insert-save-contexts
linear-scan
flatten-cfg
build-stack-frame ;
\ No newline at end of file
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors combinators namespaces
compiler.cfg.tco
compiler.cfg.dce
compiler.cfg.write-barrier
compiler.cfg.representations
+compiler.cfg.gc-checks
+compiler.cfg.save-contexts
compiler.cfg.ssa.destruction
compiler.cfg.empty-blocks
compiler.cfg.checker ;
eliminate-dead-code
eliminate-write-barriers
select-representations
+ insert-gc-checks
+ insert-save-contexts
destruct-ssa
delete-empty-blocks
?check ;
: needs-save-context? ( insns -- ? )
[
{
+ [ ##call-gc? ]
[ ##unary-float-function? ]
[ ##binary-float-function? ]
[ ##alien-invoke? ]
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry kernel namespaces
sequences sequences.deep
[ 2drop ] [ eliminate-copy ] if
] assoc-each ;
-: useless-copy? ( ##copy -- ? )
- dup ##copy? [ [ dst>> ] [ src>> ] bi eq? ] [ drop f ] if ;
+GENERIC: rename-insn ( insn -- keep? )
+
+M: vreg-insn rename-insn
+ [ rename-insn-defs ] [ rename-insn-uses ] bi t ;
+
+M: ##copy rename-insn
+ [ call-next-method drop ]
+ [ [ dst>> ] [ src>> ] bi eq? not ] bi ;
+
+M: ##phi rename-insn drop f ;
+
+M: ##call-gc rename-insn
+ [ renamings get '[ _ at ] map members ] change-gc-roots drop t ;
+
+M: insn rename-insn drop t ;
: perform-renaming ( cfg -- )
leader-map get keys [ dup leader ] H{ } map>assoc renamings set
- [
- instructions>> [
- [ rename-insn-defs ]
- [ rename-insn-uses ]
- [ [ useless-copy? ] [ ##phi? ] bi or not ] tri
- ] filter! drop
- ] each-basic-block ;
+ [ instructions>> [ rename-insn ] filter! drop ] each-basic-block ;
: destruct-ssa ( cfg -- cfg' )
needs-dominance
dup construct-cssa
dup compute-defs
- compute-ssa-live-sets
+ dup compute-ssa-live-sets
dup compute-live-ranges
dup prepare-coalescing
process-copies
: test-interference ( -- )
cfg new 0 get >>entry
- compute-ssa-live-sets
+ dup compute-ssa-live-sets
dup compute-defs
compute-live-ranges ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.order namespaces accessors kernel layouts combinators
combinators.smart assocs sequences cpu.architecture ;
{ params integer }
{ return integer }
{ total-size integer }
-{ gc-root-size integer }
{ spill-area-size integer }
{ calls-vm? boolean } ;
: spill-offset ( n -- offset )
param-base + ;
-: gc-root-base ( -- n )
- stack-frame get spill-area-size>> param-base + ;
-
-: gc-root-offset ( n -- n' ) gc-root-base + ;
-
: (stack-frame-size) ( stack-frame -- n )
[
- {
- [ params>> ]
- [ return>> ]
- [ gc-root-size>> ]
- [ spill-area-size>> ]
- } cleave
+ [ params>> ] [ return>> ] [ spill-area-size>> ] tri
] sum-outputs ;
: max-stack-frame ( frame1 frame2 -- frame3 )
{
[ [ params>> ] bi@ max >>params ]
[ [ return>> ] bi@ max >>return ]
- [ [ gc-root-size>> ] bi@ max >>gc-root-size ]
[ [ calls-vm?>> ] bi@ or >>calls-vm? ]
} 2cleave ;
\ No newline at end of file
! If both blocks are subroutine calls, don't bother
! computing anything.
2dup [ kill-block? ] both? [ 2drop ] [
- 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
- [ 2drop ] [ insert-simple-basic-block ] if-empty
+ 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ##branch ] V{ } make
+ [ 2drop ] [ insert-basic-block ] if-empty
] if ;
: visit-block ( bb -- )
: skip-empty-blocks ( bb -- bb' )
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
-:: insert-basic-block ( froms to bb -- )
- bb froms V{ } like >>predecessors drop
- bb to 1vector >>successors drop
- to predecessors>> [ dup froms member-eq? [ drop bb ] when ] map! drop
- froms [ successors>> [ dup to eq? [ drop bb ] when ] map! drop ] each ;
+:: update-predecessors ( from to bb -- )
+ ! Update 'to' predecessors for insertion of 'bb' between
+ ! 'from' and 'to'.
+ to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ;
+
+:: update-successors ( from to bb -- )
+ ! Update 'from' successors for insertion of 'bb' between
+ ! 'from' and 'to'.
+ from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
+
+:: insert-basic-block ( from to insns -- )
+ ! Insert basic block on the edge between 'from' and 'to'.
+ <basic-block> :> bb
+ insns V{ } like bb (>>instructions)
+ V{ from } bb (>>predecessors)
+ V{ to } bb (>>successors)
+ from to bb update-predecessors
+ from to bb update-successors ;
: add-instructions ( bb quot -- )
[ instructions>> building ] dip '[
,
] with-variable ; inline
-: <simple-block> ( insns -- bb )
- <basic-block>
- swap >vector
- \ ##branch new-insn over push
- >>instructions ;
-
-: insert-simple-basic-block ( from to insns -- )
- [ 1vector ] 2dip <simple-block> insert-basic-block ;
-
: has-phis? ( bb -- ? )
instructions>> first ##phi? ;
! Mapping _label IDs to label instances
SYMBOL: labels
+: lookup-label ( id -- label )
+ labels get [ drop <label> ] cache ;
+
: generate ( mr -- code )
dup label>> [
H{ } clone labels set
] each
] with-fixup ;
-: lookup-label ( id -- label )
- labels get [ drop <label> ] cache ;
-
! Special cases
M: ##no-tco generate-insn drop ;
-M: _dispatch-label generate-insn
- label>> lookup-label
- cell 0 <repetition> %
- rc-absolute-cell label-fixup ;
-
M: _prologue generate-insn
stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
SYNTAX: CODEGEN:
scan-word [ \ generate-insn create-method-in ] keep scan-word
codegen-method-body define ;
+
>>
CODEGEN: ##load-integer %load-immediate
CODEGEN: ##vm-field %vm-field
CODEGEN: ##set-vm-field %set-vm-field
CODEGEN: ##alien-global %alien-global
+CODEGEN: ##call-gc %call-gc
+
+CODEGEN: ##dispatch %dispatch
+
+: %dispatch-label ( label -- )
+ cell 0 <repetition> %
+ rc-absolute-cell label-fixup ;
-CODEGEN: _fixnum-add %fixnum-add
-CODEGEN: _fixnum-sub %fixnum-sub
-CODEGEN: _fixnum-mul %fixnum-mul
CODEGEN: _label resolve-label
+CODEGEN: _dispatch-label %dispatch-label
CODEGEN: _branch %jump-label
-CODEGEN: _compare-branch %compare-branch
-CODEGEN: _compare-imm-branch %compare-imm-branch
-CODEGEN: _compare-float-ordered-branch %compare-float-ordered-branch
-CODEGEN: _compare-float-unordered-branch %compare-float-unordered-branch
-CODEGEN: _test-vector-branch %test-vector-branch
-CODEGEN: _dispatch %dispatch
CODEGEN: _spill %spill
CODEGEN: _reload %reload
CODEGEN: _loop-entry %loop-entry
-! ##gc
-: wipe-locs ( locs temp -- )
- '[
- _
- [ 0 %load-immediate ]
- [ swap [ %replace ] with each ] bi
- ] unless-empty ;
-
-GENERIC# save-gc-root 1 ( gc-root operand temp -- )
-
-M:: spill-slot save-gc-root ( gc-root operand temp -- )
- temp int-rep operand %reload
- gc-root temp %save-gc-root ;
-
-M: object save-gc-root drop %save-gc-root ;
-
-: save-gc-roots ( gc-roots temp -- ) '[ _ save-gc-root ] assoc-each ;
-
-: save-data-regs ( data-regs -- ) [ first3 %spill ] each ;
+GENERIC: generate-conditional-insn ( label insn -- )
-GENERIC# load-gc-root 1 ( gc-root operand temp -- )
-
-M:: spill-slot load-gc-root ( gc-root operand temp -- )
- gc-root temp %load-gc-root
- temp int-rep operand %spill ;
-
-M: object load-gc-root drop %load-gc-root ;
+<<
-: load-gc-roots ( gc-roots temp -- ) '[ _ load-gc-root ] assoc-each ;
+SYNTAX: CONDITIONAL:
+ scan-word [ \ generate-conditional-insn create-method-in ] keep scan-word
+ codegen-method-body define ;
-: load-data-regs ( data-regs -- ) [ first3 %reload ] each ;
+>>
-M: ##gc generate-insn
- "no-gc" define-label
- {
- [ [ "no-gc" get ] dip [ size>> ] [ temp1>> ] [ temp2>> ] tri %check-nursery ]
- [ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
- [ data-values>> save-data-regs ]
- [ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
- [ [ temp1>> ] [ temp2>> ] bi %save-context ]
- [ [ tagged-values>> length ] [ temp1>> ] bi %call-gc ]
- [ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ]
- [ data-values>> load-data-regs ]
- } cleave
- "no-gc" resolve-label ;
+CONDITIONAL: ##compare-branch %compare-branch
+CONDITIONAL: ##compare-imm-branch %compare-imm-branch
+CONDITIONAL: ##compare-integer-branch %compare-branch
+CONDITIONAL: ##compare-integer-imm-branch %compare-imm-branch
+CONDITIONAL: ##compare-float-ordered-branch %compare-float-ordered-branch
+CONDITIONAL: ##compare-float-unordered-branch %compare-float-unordered-branch
+CONDITIONAL: ##test-vector-branch %test-vector-branch
+CONDITIONAL: ##check-nursery-branch %check-nursery-branch
+CONDITIONAL: ##fixnum-add %fixnum-add
+CONDITIONAL: ##fixnum-sub %fixnum-sub
+CONDITIONAL: ##fixnum-mul %fixnum-mul
+
+M: _conditional-branch generate-insn
+ [ label>> lookup-label ] [ insn>> ] bi generate-conditional-insn ;
! ##alien-invoke
GENERIC: next-fastcall-param ( rep -- )
: %tagged>integer ( dst src -- ) int-rep %copy ;
-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: %fixnum-add cpu ( label dst src1 src2 cc -- )
+HOOK: %fixnum-sub cpu ( label dst src1 src2 cc -- )
+HOOK: %fixnum-mul cpu ( label dst src1 src2 cc -- )
HOOK: %add-float cpu ( dst src1 src2 -- )
HOOK: %sub-float cpu ( dst src1 src2 -- )
HOOK: %write-barrier-imm cpu ( src slot tag temp1 temp2 -- )
! GC checks
-HOOK: %check-nursery cpu ( label size temp1 temp2 -- )
-HOOK: %save-gc-root cpu ( gc-root register -- )
-HOOK: %load-gc-root cpu ( gc-root register -- )
-HOOK: %call-gc cpu ( gc-root-count temp1 -- )
+HOOK: %check-nursery-branch cpu ( label size cc temp1 temp2 -- )
+HOOK: %call-gc cpu ( gc-roots -- )
HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- )
M: x86.32 %cleanup ( params -- )
stack-cleanup [ ESP swap SUB ] unless-zero ;
-M:: x86.32 %call-gc ( gc-root-count temp -- )
- temp gc-root-base special@ LEA
- 8 save-vm-ptr
- 4 stack@ gc-root-count MOV
- 0 stack@ temp MOV
+M:: x86.32 %call-gc ( gc-roots -- )
+ 4 save-vm-ptr
+ EAX gc-roots gc-root-offsets %load-reference
+ 0 stack@ EAX MOV
"inline_gc" f %alien-invoke ;
M: x86.32 dummy-stack-params? f ;
func "libm" load-library %alien-invoke
dst float-function-return ;
-M:: x86.64 %call-gc ( gc-root-count temp -- )
- ! Pass pointer to start of GC roots as first parameter
- param-reg-0 gc-root-base param@ LEA
- ! Pass number of roots as second parameter
- param-reg-1 gc-root-count MOV
- ! Pass VM ptr as third parameter
- param-reg-2 %mov-vm-ptr
- ! Call GC
+M:: x86.64 %call-gc ( gc-roots -- )
+ param-reg-0 gc-roots gc-root-offsets %load-reference
+ param-reg-1 %mov-vm-ptr
"inline_gc" f %alien-invoke ;
M: x86.64 struct-return-pointer-type void* ;
: SAR ( dst n -- ) BIN: 111 (SHIFT) ;
: IMUL2 ( dst src -- )
- swap OCT: 257 extended-opcode (2-operand) ;
+ OCT: 257 extended-opcode (2-operand) ;
: IMUL3 ( dst src imm -- )
dup fits-in-byte? [
! multiply
temp0 temp1 IMUL2
! push result
- ds-reg [] temp1 MOV
+ ds-reg [] temp0 MOV
] \ fixnum*fast define-sub-primitive
[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
: stack@ ( n -- op ) stack-reg swap [+] ;
-: special@ ( n -- op )
+: special-offset ( m -- n )
stack-frame get extra-stack-space +
- reserved-stack-space +
- stack@ ;
+ reserved-stack-space + ;
-: spill@ ( n -- op ) spill-offset special@ ;
+: special@ ( n -- op ) special-offset stack@ ;
-: gc-root@ ( n -- op ) gc-root-offset special@ ;
+: spill@ ( n -- op ) spill-offset special@ ;
: param@ ( n -- op ) reserved-stack-space + stack@ ;
+: gc-root-offsets ( seq -- seq' )
+ [ n>> special-offset ] map f like ;
+
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
M: x86 %add-imm 2over eq? [ nip ADD ] [ [+] LEA ] if ;
M: x86 %sub int-rep two-operand SUB ;
M: x86 %sub-imm 2over eq? [ nip SUB ] [ neg [+] LEA ] if ;
-M: x86 %mul int-rep two-operand swap IMUL2 ;
+M: x86 %mul int-rep two-operand IMUL2 ;
M: x86 %mul-imm IMUL3 ;
M: x86 %and int-rep two-operand AND ;
M: x86 %and-imm int-rep two-operand AND ;
2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
] if ;
-M: x86 %fixnum-add ( label dst src1 src2 -- )
- int-rep two-operand ADD JO ;
+: fixnum-overflow ( label dst src1 src2 cc quot -- )
+ swap [ [ int-rep two-operand ] dip call ] dip
+ {
+ { cc-o [ JO ] }
+ { cc/o [ JNO ] }
+ } case ; inline
-M: x86 %fixnum-sub ( label dst src1 src2 -- )
- int-rep two-operand SUB JO ;
+M: x86 %fixnum-add ( label dst src1 src2 cc -- )
+ [ ADD ] fixnum-overflow ;
-M: x86 %fixnum-mul ( label dst src1 src2 -- )
- int-rep two-operand swap IMUL2 JO ;
+M: x86 %fixnum-sub ( label dst src1 src2 cc -- )
+ [ SUB ] fixnum-overflow ;
+
+M: x86 %fixnum-mul ( label dst src1 src2 cc -- )
+ [ IMUL2 ] fixnum-overflow ;
M: x86 %unbox-alien ( dst src -- )
alien-offset [+] MOV ;
temp1 src slot tag (%slot-imm) LEA
temp1 temp2 (%write-barrier) ;
-M:: x86 %check-nursery ( label size temp1 temp2 -- )
+M:: x86 %check-nursery-branch ( label size cc temp1 temp2 -- )
temp1 load-zone-offset
- ! Load 'here' into temp2
temp2 temp1 [] MOV
temp2 size ADD
- ! Load 'end' into temp1
- temp1 temp1 2 cells [+] MOV
- temp2 temp1 CMP
- label JLE ;
-
-M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
-
-M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
+ temp2 temp1 2 cells [+] CMP
+ cc {
+ { cc<= [ label JLE ] }
+ { cc/<= [ label JG ] }
+ } case ;
M: x86 %alien-global ( dst symbol library -- )
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
true /* trace contexts? */);
}
-void factor_vm::inline_gc(cell *data_roots_base, cell data_roots_size)
+void factor_vm::inline_gc(cell gc_roots_)
{
- data_roots.push_back(data_root_range(data_roots_base,data_roots_size));
- primitive_minor_gc();
- data_roots.pop_back();
+ cell stack_pointer = (cell)ctx->callstack_top + sizeof(cell);
+
+ if(to_boolean(gc_roots_))
+ {
+ tagged<array> gc_roots(gc_roots_);
+
+ cell capacity = array_capacity(gc_roots.untagged());
+ for(cell i = 0; i < capacity; i++)
+ {
+ cell spill_slot = untag_fixnum(array_nth(gc_roots.untagged(),i));
+ cell *address = (cell *)(spill_slot + stack_pointer);
+ data_roots.push_back(data_root_range(address,1));
+ }
+
+ primitive_minor_gc();
+
+ for(cell i = 0; i < capacity; i++)
+ data_roots.pop_back();
+ }
+ else
+ primitive_minor_gc();
}
-VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *parent)
+VM_C_API void inline_gc(cell gc_roots, factor_vm *parent)
{
- parent->inline_gc(data_roots_base,data_roots_size);
+ parent->inline_gc(gc_roots);
}
/*
void start_again(gc_op op_, factor_vm *parent);
};
-VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *parent);
+VM_C_API void inline_gc(cell gc_roots, factor_vm *parent);
}
void primitive_minor_gc();
void primitive_full_gc();
void primitive_compact_gc();
- void inline_gc(cell *data_roots_base, cell data_roots_size);
+ void inline_gc(cell gc_roots);
void primitive_enable_gc_events();
void primitive_disable_gc_events();
object *allot_object(cell type, cell size);
projects / factor.git / commitdiff