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

Merge branch 'master' of git://factorcode.org/git/factor 

Conflicts:
	unmaintained/modules/rpc-server/rpc-server.factor
db4
Sam Anklesaria 2009-06-14 11:56:45 -05:00
parent b265e3afea b18c84454b
commit 63204e677a
213 changed files with 5834 additions and 2224 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
basis/bitstreams/bitstreams.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.accessors assocs byte-arrays combinators USING: accessors alien.accessors assocs byte-arrays combinators
constructors destructors fry io io.binary io.encodings.binary destructors fry io io.binary io.encodings.binary io.streams.byte-array
io.streams.byte-array kernel locals macros math math.ranges kernel locals macros math math.ranges multiline sequences
multiline sequences sequences.private vectors byte-vectors sequences.private vectors byte-vectors combinators.short-circuit
combinators.short-circuit math.bitwise ; math.bitwise ;
IN: bitstreams IN: bitstreams
TUPLE: widthed { bits integer read-only } { #bits integer read-only } ; TUPLE: widthed { bits integer read-only } { #bits integer read-only } ;
@ -36,8 +36,12 @@ TUPLE: bit-writer
TUPLE: msb0-bit-reader < bit-reader ; TUPLE: msb0-bit-reader < bit-reader ;
TUPLE: lsb0-bit-reader < bit-reader ; TUPLE: lsb0-bit-reader < bit-reader ;
CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ;
CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ; : <msb0-bit-reader> ( bytes -- bs )
msb0-bit-reader new swap >>bytes ; inline
: <lsb0-bit-reader> ( bytes -- bs )
lsb0-bit-reader new swap >>bytes ; inline
TUPLE: msb0-bit-writer < bit-writer ; TUPLE: msb0-bit-writer < bit-writer ;
TUPLE: lsb0-bit-writer < bit-writer ; TUPLE: lsb0-bit-writer < bit-writer ;
@ -56,13 +60,20 @@ TUPLE: lsb0-bit-writer < bit-writer ;
GENERIC: peek ( n bitstream -- value ) GENERIC: peek ( n bitstream -- value )
GENERIC: poke ( value n bitstream -- ) GENERIC: poke ( value n bitstream -- )
: get-abp ( bitstream -- abp )
[ byte-pos>> 8 * ] [ bit-pos>> + ] bi ; inline
: set-abp ( abp bitstream -- )
[ 8 /mod ] dip [ (>>bit-pos) ] [ (>>byte-pos) ] bi ; inline
: seek ( n bitstream -- ) : seek ( n bitstream -- )
{ [ get-abp + ] [ set-abp ] bi ; inline
[ byte-pos>> 8 * ]
[ bit-pos>> + + 8 /mod ] : (align) ( n m -- n' )
[ (>>bit-pos) ] [ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline
[ (>>byte-pos) ]
} cleave ; inline : align ( n bitstream -- )
[ get-abp swap (align) ] [ set-abp ] bi ; inline
: read ( n bitstream -- value ) : read ( n bitstream -- value )
[ peek ] [ seek ] 2bi ; inline [ peek ] [ seek ] 2bi ; inline
@ -158,3 +169,9 @@ M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
writer bytes>> swap push writer bytes>> swap push
] unless ] unless
writer bytes>> ; writer bytes>> ;
:: byte-array-n>seq ( byte-array n -- seq )
byte-array length 8 * n / iota
byte-array <msb0-bit-reader> '[
drop n _ read
] { } map-as ;

1
basis/circular/circular-tests.factor
View File

@ -13,6 +13,7 @@ circular strings ;
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test [ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ ] like ] unit-test [ [ 2 3 1 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ ] like ] unit-test
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ rotate-circular ] keep [ ] like ] unit-test
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start [ ] like ] unit-test [ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start [ ] like ] unit-test
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test

4
basis/circular/circular.factor
View File

@ -28,10 +28,10 @@ M: circular virtual-seq seq>> ;
circular-wrap (>>start) ; circular-wrap (>>start) ;
: rotate-circular ( circular -- ) : rotate-circular ( circular -- )
[ start>> 1 + ] keep circular-wrap (>>start) ; [ 1 ] dip change-circular-start ;
: push-circular ( elt circular -- ) : push-circular ( elt circular -- )
[ set-first ] [ 1 swap change-circular-start ] bi ; [ set-first ] [ rotate-circular ] bi ;
: <circular-string> ( n -- circular ) : <circular-string> ( n -- circular )
0 <string> <circular> ; 0 <string> <circular> ;

55
basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
View File

@ -1,56 +1 @@
USING: compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.alias-analysis compiler.cfg.debugger
cpu.architecture tools.test kernel ;
IN: compiler.cfg.alias-analysis.tests IN: compiler.cfg.alias-analysis.tests
[ ] [
{
T{ ##peek f V int-regs 2 D 1 f }
T{ ##box-alien f V int-regs 1 V int-regs 2 }
T{ ##slot-imm f V int-regs 3 V int-regs 1 0 3 }
} alias-analysis drop
] unit-test
[ ] [
{
T{ ##load-reference f V int-regs 1 "hello" }
T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
} alias-analysis drop
] unit-test
[
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 2 f }
T{ ##replace f V int-regs 1 D 0 f }
}
] [
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 2 f }
T{ ##replace f V int-regs 2 D 0 f }
T{ ##replace f V int-regs 1 D 0 f }
} alias-analysis
] unit-test
[
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 0 f }
T{ ##copy f V int-regs 3 V int-regs 2 f }
T{ ##copy f V int-regs 4 V int-regs 1 f }
T{ ##replace f V int-regs 3 D 0 f }
T{ ##replace f V int-regs 4 D 1 f }
}
] [
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 0 f }
T{ ##replace f V int-regs 1 D 0 f }
T{ ##replace f V int-regs 2 D 1 f }
T{ ##peek f V int-regs 3 D 1 f }
T{ ##peek f V int-regs 4 D 0 f }
T{ ##replace f V int-regs 3 D 0 f }
T{ ##replace f V int-regs 4 D 1 f }
} alias-analysis
] unit-test

67
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -1,15 +1,13 @@
! 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: kernel math namespaces assocs hashtables sequences arrays USING: kernel math namespaces assocs hashtables sequences arrays
accessors vectors combinators sets classes compiler.cfg accessors vectors combinators sets classes compiler.cfg
compiler.cfg.registers compiler.cfg.instructions compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.copy-prop ; compiler.cfg.copy-prop compiler.cfg.rpo
compiler.cfg.liveness compiler.cfg.local ;
IN: compiler.cfg.alias-analysis IN: compiler.cfg.alias-analysis
! Alias analysis -- assumes compiler.cfg.height has already run. ! We try to eliminate redundant slot operations using some simple heuristics.
!
! We try to eliminate redundant slot and stack
! traffic using some simple heuristics.
! !
! All heap-allocated objects which are loaded from the stack, or ! All heap-allocated objects which are loaded from the stack, or
! other object slots are pessimistically assumed to belong to ! other object slots are pessimistically assumed to belong to
@ -17,9 +15,6 @@ IN: compiler.cfg.alias-analysis
! !
! Freshly-allocated objects get their own alias class. ! Freshly-allocated objects get their own alias class.
! !
! The data and retain stack pointer registers are treated
! uniformly, and each one gets its own alias class.
!
! Simple pseudo-C example showing load elimination: ! Simple pseudo-C example showing load elimination:
! !
! int *x, *y, z: inputs ! int *x, *y, z: inputs
@ -68,15 +63,14 @@ IN: compiler.cfg.alias-analysis
! Map vregs -> alias classes ! Map vregs -> alias classes
SYMBOL: vregs>acs SYMBOL: vregs>acs
: check ( obj -- obj ) ERROR: vreg-ac-not-set vreg ;
[ "BUG: static type error detected" throw ] unless* ; inline
: vreg>ac ( vreg -- ac ) : vreg>ac ( vreg -- ac )
#! Only vregs produced by ##allot, ##peek and ##slot can #! Only vregs produced by ##allot, ##peek and ##slot can
#! ever be used as valid inputs to ##slot and ##set-slot, #! ever be used as valid inputs to ##slot and ##set-slot,
#! so we assert this fact by not giving alias classes to #! so we assert this fact by not giving alias classes to
#! other vregs. #! other vregs.
vregs>acs get at check ; vregs>acs get ?at [ vreg-ac-not-set ] unless ;
! Map alias classes -> sequence of vregs ! Map alias classes -> sequence of vregs
SYMBOL: acs>vregs SYMBOL: acs>vregs
@ -122,8 +116,10 @@ SYMBOL: histories
#! value. #! value.
over [ live-slots get at at ] [ 2drop f ] if ; over [ live-slots get at at ] [ 2drop f ] if ;
ERROR: vreg-has-no-slots vreg ;
: load-constant-slot ( value slot# vreg -- ) : load-constant-slot ( value slot# vreg -- )
live-slots get at check set-at ; live-slots get ?at [ vreg-has-no-slots ] unless set-at ;
: load-slot ( value slot#/f vreg -- ) : load-slot ( value slot#/f vreg -- )
over [ load-constant-slot ] [ 3drop ] if ; over [ load-constant-slot ] [ 3drop ] if ;
@ -189,23 +185,19 @@ SYMBOL: constants
GENERIC: insn-slot# ( insn -- slot#/f ) GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg ) GENERIC: insn-object ( insn -- vreg )
M: ##peek insn-slot# loc>> n>> ;
M: ##replace insn-slot# loc>> n>> ;
M: ##slot insn-slot# slot>> constant ; M: ##slot insn-slot# slot>> constant ;
M: ##slot-imm insn-slot# slot>> ; M: ##slot-imm insn-slot# slot>> ;
M: ##set-slot insn-slot# slot>> constant ; M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot-imm insn-slot# slot>> ; M: ##set-slot-imm insn-slot# slot>> ;
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ; M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
M: ##peek insn-object loc>> class ;
M: ##replace insn-object loc>> class ;
M: ##slot insn-object obj>> resolve ; M: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ; M: ##slot-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ; M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ; M: ##set-slot-imm insn-object obj>> resolve ;
M: ##alien-global insn-object drop \ ##alien-global ; M: ##alien-global insn-object drop \ ##alien-global ;
: init-alias-analysis ( -- ) : init-alias-analysis ( live-in -- )
H{ } clone histories set H{ } clone histories set
H{ } clone vregs>acs set H{ } clone vregs>acs set
H{ } clone acs>vregs set H{ } clone acs>vregs set
@ -216,40 +208,26 @@ M: ##alien-global insn-object drop \ ##alien-global ;
0 ac-counter set 0 ac-counter set
next-ac heap-ac set next-ac heap-ac set
ds-loc next-ac set-ac [ set-heap-ac ] each ;
rs-loc next-ac set-ac ;
GENERIC: analyze-aliases* ( insn -- insn' ) GENERIC: analyze-aliases* ( insn -- insn' )
M: ##load-immediate analyze-aliases* M: ##load-immediate analyze-aliases*
dup [ val>> ] [ dst>> ] bi constants get set-at ; dup [ val>> ] [ dst>> ] bi constants get set-at ;
M: ##load-reference analyze-aliases* M: ##flushable analyze-aliases*
dup dst>> set-heap-ac ; dup dst>> set-heap-ac ;
M: ##alien-global analyze-aliases* M: ##allocation analyze-aliases*
dup dst>> set-heap-ac ;
M: ##allot analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
dup dst>> set-new-ac ;
M: ##box-float analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
dup dst>> set-new-ac ;
M: ##box-alien analyze-aliases*
#! A freshly allocated object is distinct from any other #! A freshly allocated object is distinct from any other
#! object. #! object.
dup dst>> set-new-ac ; dup dst>> set-new-ac ;
M: ##read analyze-aliases* M: ##read analyze-aliases*
dup dst>> set-heap-ac call-next-method
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
2dup live-slot dup [ 2dup live-slot dup [
2nip f \ ##copy boa analyze-aliases* nip 2nip \ ##copy new-insn analyze-aliases* nip
] [ ] [
drop remember-slot drop remember-slot
] if ; ] if ;
@ -292,15 +270,6 @@ GENERIC: eliminate-dead-stores* ( insn -- insn' )
] unless ] unless
] when ; ] when ;
M: ##replace eliminate-dead-stores*
#! Writes to above the top of the stack can be pruned also.
#! This is sound since any such writes are not observable
#! after the basic block, and any reads of those locations
#! will have been converted to copies by analyze-slot,
#! and the final stack height of the basic block is set at
#! the beginning by compiler.cfg.stack.
dup loc>> n>> 0 < [ drop f ] [ (eliminate-dead-stores) ] if ;
M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ; M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ; M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ;
@ -310,8 +279,10 @@ M: insn eliminate-dead-stores* ;
: eliminate-dead-stores ( insns -- insns' ) : eliminate-dead-stores ( insns -- insns' )
[ insn# set eliminate-dead-stores* ] map-index sift ; [ insn# set eliminate-dead-stores* ] map-index sift ;
: alias-analysis ( insns -- insns' ) : alias-analysis-step ( insns -- insns' )
init-alias-analysis
analyze-aliases analyze-aliases
compute-live-stores compute-live-stores
eliminate-dead-stores ; eliminate-dead-stores ;
: alias-analysis ( cfg -- cfg' )
[ init-alias-analysis ] [ alias-analysis-step ] local-optimization ;

74
basis/compiler/cfg/build-stack-frame/build-stack-frame.factor Normal file
View File

@ -0,0 +1,74 @@
! Copyright (C) 2008 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
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.stack-frame ;
IN: compiler.cfg.build-stack-frame
SYMBOL: frame-required?
SYMBOL: spill-counts
GENERIC: compute-stack-frame* ( insn -- )
: request-stack-frame ( stack-frame -- )
stack-frame [ max-stack-frame ] change ;
M: ##stack-frame compute-stack-frame*
frame-required? on
stack-frame>> request-stack-frame ;
M: ##call compute-stack-frame*
word>> sub-primitive>> [ frame-required? on ] unless ;
M: _gc compute-stack-frame*
frame-required? on
stack-frame new swap gc-root-size>> >>gc-root-size
request-stack-frame ;
M: _spill-counts compute-stack-frame*
counts>> stack-frame get (>>spill-counts) ;
M: insn compute-stack-frame*
class frame-required? word-prop [
frame-required? on
] 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
T{ stack-frame } clone stack-frame set
[ compute-stack-frame* ] each
stack-frame get dup stack-frame-size >>total-size drop ;
GENERIC: insert-pro/epilogues* ( insn -- )
M: ##stack-frame insert-pro/epilogues* drop ;
M: ##prologue insert-pro/epilogues*
drop frame-required? get [ stack-frame get _prologue ] when ;
M: ##epilogue insert-pro/epilogues*
drop frame-required? get [ stack-frame get _epilogue ] when ;
M: insn insert-pro/epilogues* , ;
: insert-pro/epilogues ( insns -- insns )
[ [ insert-pro/epilogues* ] each ] { } make ;
: build-stack-frame ( mr -- mr )
[
[
[ compute-stack-frame ]
[ insert-pro/epilogues ]
bi
] change-instructions
] with-scope ;

0
basis/compiler/cfg/stack-frame/summary.txt → basis/compiler/cfg/build-stack-frame/summary.txt
View File

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

@ -15,6 +15,7 @@ compiler.cfg.iterator
compiler.cfg.utilities compiler.cfg.utilities
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.intrinsics compiler.cfg.intrinsics
compiler.cfg.stack-frame
compiler.cfg.instructions compiler.cfg.instructions
compiler.alien ; compiler.alien ;
IN: compiler.cfg.builder IN: compiler.cfg.builder
@ -81,30 +82,35 @@ GENERIC: emit-node ( node -- next )
basic-block get successors>> push basic-block get successors>> push
stop-iterating ; stop-iterating ;
: emit-call ( word -- next ) : emit-call ( word height -- next )
{ {
{ [ dup loops get key? ] [ loops get at local-recursive-call ] } { [ over loops get key? ] [ drop loops get at local-recursive-call ] }
{ [ terminate-call? ] [ ##call stop-iterating ] }
{ [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] } { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
{ [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] } { [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] }
[ ##epilogue ##jump stop-iterating ] [ drop ##epilogue ##jump stop-iterating ]
} cond ; } cond ;
! #recursive ! #recursive
: compile-recursive ( node -- next ) : recursive-height ( #recursive -- n )
[ label>> id>> emit-call ] [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
: emit-recursive ( #recursive -- next )
[ [ label>> id>> ] [ recursive-height ] bi emit-call ]
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ; [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
: remember-loop ( label -- ) : remember-loop ( label -- )
basic-block get swap loops get set-at ; basic-block get swap loops get set-at ;
: compile-loop ( node -- next ) : emit-loop ( node -- next )
##loop-entry ##loop-entry
##branch
begin-basic-block begin-basic-block
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
iterate-next ; iterate-next ;
M: #recursive emit-node M: #recursive emit-node
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ; dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
! #if ! #if
: emit-branch ( obj -- final-bb ) : emit-branch ( obj -- final-bb )
@ -154,65 +160,16 @@ M: #if emit-node
} cond iterate-next ; } cond iterate-next ;
! #dispatch ! #dispatch
: trivial-dispatch-branch? ( nodes -- ? )
dup length 1 = [
first dup #call? [
word>> "intrinsic" word-prop not
] [ drop f ] if
] [ drop f ] if ;
: dispatch-branch ( nodes word -- label )
over trivial-dispatch-branch? [
drop first word>>
] [
gensym [
[
V{ } clone node-stack set
##prologue
begin-basic-block
emit-nodes
basic-block get [
##epilogue
##return
end-basic-block
] when
] with-cfg-builder
] keep
] if ;
: dispatch-branches ( node -- )
children>> [
current-word get dispatch-branch
##dispatch-label
] each ;
: emit-dispatch ( node -- )
##epilogue
ds-pop ^^offset>slot i 0 ##dispatch
dispatch-branches ;
: <dispatch-block> ( -- word )
gensym dup t "inlined-block" set-word-prop ;
M: #dispatch emit-node M: #dispatch emit-node
tail-call? [ ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
emit-dispatch stop-iterating
] [
current-word get <dispatch-block> [
[
begin-word
emit-dispatch
] with-cfg-builder
] keep emit-call
] if ;
! #call ! #call
M: #call emit-node M: #call emit-node
dup word>> dup "intrinsic" word-prop dup word>> dup "intrinsic" word-prop
[ emit-intrinsic ] [ nip emit-call ] if ; [ emit-intrinsic ] [ swap call-height emit-call ] if ;
! #call-recursive ! #call-recursive
M: #call-recursive emit-node label>> id>> emit-call ; M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
! #push ! #push
M: #push emit-node M: #push emit-node

24
basis/compiler/cfg/cfg.factor
View File

@ -1,27 +1,37 @@
! 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: kernel arrays vectors accessors namespaces ; USING: kernel arrays vectors accessors
namespaces math make fry sequences ;
IN: compiler.cfg IN: compiler.cfg
TUPLE: basic-block < identity-tuple TUPLE: basic-block < identity-tuple
id { id integer }
number number
{ instructions vector } { instructions vector }
{ successors vector } { successors vector }
{ predecessors vector } ; { predecessors vector } ;
: <basic-block> ( -- basic-block ) M: basic-block hashcode* nip id>> ;
: <basic-block> ( -- bb )
basic-block new basic-block new
V{ } clone >>instructions V{ } clone >>instructions
V{ } clone >>successors V{ } clone >>successors
V{ } clone >>predecessors V{ } clone >>predecessors
\ basic-block counter >>id ; \ basic-block counter >>id ;
TUPLE: cfg { entry basic-block } word label ; : add-instructions ( bb quot -- )
[ instructions>> building ] dip '[
building get pop
_ dip
building get push
] with-variable ; inline
C: <cfg> cfg TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
TUPLE: mr { instructions array } word label spill-counts ; : <cfg> ( entry word label -- cfg ) f f cfg boa ;
TUPLE: mr { instructions array } word label ;
: <mr> ( instructions word label -- mr ) : <mr> ( instructions word label -- mr )
mr new mr new

0
basis/constructors/authors.txt → basis/compiler/cfg/checker/authors.txt
View File

61
basis/compiler/cfg/checker/checker.factor Normal file
View File

@ -0,0 +1,61 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.liveness
combinators.short-circuit accessors math sequences sets assocs ;
IN: compiler.cfg.checker
ERROR: last-insn-not-a-jump insn ;
: check-last-instruction ( bb -- )
last dup {
[ ##branch? ]
[ ##dispatch? ]
[ ##conditional-branch? ]
[ ##compare-imm-branch? ]
[ ##return? ]
[ ##callback-return? ]
[ ##jump? ]
[ ##fixnum-add-tail? ]
[ ##fixnum-sub-tail? ]
[ ##fixnum-mul-tail? ]
[ ##call? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
ERROR: bad-loop-entry ;
: check-loop-entry ( bb -- )
dup length 2 >= [
2 head* [ ##loop-entry? ] any?
[ bad-loop-entry ] when
] [ drop ] if ;
ERROR: bad-successors ;
: check-successors ( bb -- )
dup successors>> [ predecessors>> memq? ] with all?
[ bad-successors ] unless ;
: check-basic-block ( bb -- )
[ instructions>> check-last-instruction ]
[ instructions>> check-loop-entry ]
[ check-successors ]
tri ;
ERROR: bad-live-in ;
ERROR: undefined-values uses defs ;
: check-mr ( mr -- )
! Check that every used register has a definition
instructions>>
[ [ uses-vregs ] map concat ]
[ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi
2dup subset? [ 2drop ] [ undefined-values ] if ;
: check-cfg ( cfg -- )
compute-liveness
[ entry>> live-in assoc-empty? [ bad-live-in ] unless ]
[ [ check-basic-block ] each-basic-block ]
[ flatten-cfg check-mr ]
tri ;

2
basis/compiler/cfg/copy-prop/copy-prop.factor
View File

@ -6,7 +6,7 @@ IN: compiler.cfg.copy-prop
SYMBOL: copies SYMBOL: copies
: resolve ( vreg -- vreg ) : resolve ( vreg -- vreg )
dup copies get at swap or ; [ copies get at ] keep or ;
: record-copy ( insn -- ) : record-copy ( insn -- )
[ src>> resolve ] [ dst>> ] bi copies get set-at ; inline [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline

1
basis/compiler/cfg/dce/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

45
basis/compiler/cfg/dce/dce.factor Normal file
View File

@ -0,0 +1,45 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sets kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.def-use
compiler.cfg.rpo ;
IN: compiler.cfg.dce
! Maps vregs to sequences of vregs
SYMBOL: liveness-graph
! vregs which participate in side effects and thus are always live
SYMBOL: live-vregs
: init-dead-code ( -- )
H{ } clone liveness-graph set
H{ } clone live-vregs set ;
GENERIC: update-liveness-graph ( insn -- )
M: ##flushable update-liveness-graph
[ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
: record-live ( vregs -- )
[
dup live-vregs get key? [ drop ] [
[ live-vregs get conjoin ]
[ liveness-graph get at record-live ]
bi
] if
] each ;
M: insn update-liveness-graph uses-vregs record-live ;
GENERIC: live-insn? ( insn -- ? )
M: ##flushable live-insn? dst>> live-vregs get key? ;
M: insn live-insn? drop t ;
: eliminate-dead-code ( cfg -- cfg' )
init-dead-code
[ [ instructions>> [ update-liveness-graph ] each ] each-basic-block ]
[ [ [ [ live-insn? ] filter ] change-instructions drop ] each-basic-block ]
[ ]
tri ;

9
basis/compiler/cfg/dead-code/dead-code-tests.factor
View File

@ -1,9 +0,0 @@
USING: compiler.cfg.dead-code compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger
cpu.architecture tools.test ;
IN: compiler.cfg.dead-code.tests
[ { } ] [
{ T{ ##load-immediate f V int-regs 134 16 } }
eliminate-dead-code
] unit-test

61
basis/compiler/cfg/dead-code/dead-code.factor
View File

@ -1,61 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sets kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.def-use ;
IN: compiler.cfg.dead-code
! Dead code elimination -- assumes compiler.cfg.alias-analysis
! has already run.
! Maps vregs to sequences of vregs
SYMBOL: liveness-graph
! vregs which participate in side effects and thus are always live
SYMBOL: live-vregs
! mapping vregs to stack locations
SYMBOL: vregs>locs
: init-dead-code ( -- )
H{ } clone liveness-graph set
H{ } clone live-vregs set
H{ } clone vregs>locs set ;
GENERIC: compute-liveness ( insn -- )
M: ##flushable compute-liveness
[ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
M: ##peek compute-liveness
[ [ loc>> ] [ dst>> ] bi vregs>locs get set-at ]
[ call-next-method ]
bi ;
: live-replace? ( ##replace -- ? )
[ src>> vregs>locs get at ] [ loc>> ] bi = not ;
M: ##replace compute-liveness
dup live-replace? [ call-next-method ] [ drop ] if ;
: record-live ( vregs -- )
[
dup live-vregs get key? [ drop ] [
[ live-vregs get conjoin ]
[ liveness-graph get at record-live ]
bi
] if
] each ;
M: insn compute-liveness uses-vregs record-live ;
GENERIC: live-insn? ( insn -- ? )
M: ##flushable live-insn? dst>> live-vregs get key? ;
M: ##replace live-insn? live-replace? ;
M: insn live-insn? drop t ;
: eliminate-dead-code ( insns -- insns' )
init-dead-code
[ [ compute-liveness ] each ] [ [ live-insn? ] filter ] bi ;

1
basis/compiler/cfg/dead-code/summary.txt
View File

@ -1 +0,0 @@
Dead-code elimination

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

@ -7,7 +7,8 @@ parser compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.linearization compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.registers compiler.cfg.stack-frame compiler.cfg.registers compiler.cfg.stack-frame
compiler.cfg.linear-scan compiler.cfg.two-operand compiler.cfg.linear-scan compiler.cfg.two-operand
compiler.cfg.optimizer ; compiler.cfg.liveness compiler.cfg.optimizer
compiler.cfg.mr ;
IN: compiler.cfg.debugger IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs ) GENERIC: test-cfg ( quot -- cfgs )
@ -18,20 +19,14 @@ M: callable test-cfg
M: word test-cfg M: word test-cfg
[ build-tree optimize-tree ] keep build-cfg ; [ build-tree optimize-tree ] keep build-cfg ;
SYMBOL: allocate-registers?
: test-mr ( quot -- mrs ) : test-mr ( quot -- mrs )
test-cfg [ test-cfg [
optimize-cfg optimize-cfg
build-mr build-mr
convert-two-operand
allocate-registers? get
[ linear-scan build-stack-frame ] when
] map ; ] map ;
: insn. ( insn -- ) : insn. ( insn -- )
tuple>array allocate-registers? get [ but-last ] unless tuple>array [ pprint bl ] each nl ;
[ pprint bl ] each nl ;
: mr. ( mrs -- ) : mr. ( mrs -- )
[ [

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

@ -1,28 +1,32 @@
! 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: accessors arrays kernel compiler.cfg.instructions ; USING: accessors arrays kernel compiler.cfg.instructions ;
IN: compiler.cfg.def-use IN: compiler.cfg.def-use
GENERIC: defs-vregs ( insn -- seq ) GENERIC: defs-vregs ( insn -- seq )
GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq )
: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
M: ##flushable defs-vregs dst>> 1array ; M: ##flushable defs-vregs dst>> 1array ;
M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
M: ##unary/temp defs-vregs dst/tmp-vregs ;
M: ##allot defs-vregs dst/tmp-vregs ;
M: ##dispatch defs-vregs temp>> 1array ;
M: ##slot defs-vregs dst/tmp-vregs ;
M: ##set-slot defs-vregs temp>> 1array ;
M: ##string-nth defs-vregs dst/tmp-vregs ;
M: ##set-string-nth-fast defs-vregs temp>> 1array ;
M: ##compare defs-vregs dst/tmp-vregs ;
M: ##compare-imm defs-vregs dst/tmp-vregs ;
M: ##compare-float defs-vregs dst/tmp-vregs ;
M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: insn defs-vregs drop f ; M: insn defs-vregs drop f ;
M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
M: ##unary/temp temp-vregs temp>> 1array ;
M: ##allot temp-vregs temp>> 1array ;
M: ##dispatch temp-vregs temp>> 1array ;
M: ##slot temp-vregs temp>> 1array ;
M: ##set-slot temp-vregs temp>> 1array ;
M: ##string-nth temp-vregs temp>> 1array ;
M: ##set-string-nth-fast temp-vregs temp>> 1array ;
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 ;
M: ##unary uses-vregs src>> 1array ; M: ##unary uses-vregs src>> 1array ;
M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##binary-imm uses-vregs src1>> 1array ; M: ##binary-imm uses-vregs src1>> 1array ;
@ -39,10 +43,13 @@ M: ##dispatch uses-vregs src>> 1array ;
M: ##alien-getter uses-vregs src>> 1array ; M: ##alien-getter uses-vregs src>> 1array ;
M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ; M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##phi uses-vregs inputs>> ;
M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: _compare-imm-branch uses-vregs src1>> 1array ; M: _compare-imm-branch uses-vregs src1>> 1array ;
M: _dispatch uses-vregs src>> 1array ;
M: insn uses-vregs drop f ; M: insn uses-vregs drop f ;
! Instructions that use vregs
UNION: vreg-insn UNION: vreg-insn
##flushable ##flushable
##write-barrier ##write-barrier
@ -51,5 +58,8 @@ UNION: vreg-insn
##fixnum-overflow ##fixnum-overflow
##conditional-branch ##conditional-branch
##compare-imm-branch ##compare-imm-branch
##phi
##gc
_conditional-branch _conditional-branch
_compare-imm-branch ; _compare-imm-branch
_dispatch ;

1
basis/compiler/cfg/dominance/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

41
basis/compiler/cfg/dominance/dominance.factor Normal file
View File

@ -0,0 +1,41 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators compiler.cfg.rpo
compiler.cfg.stack-analysis fry kernel math.order namespaces
sequences ;
IN: compiler.cfg.dominance
! Reference:
! A Simple, Fast Dominance Algorithm
! Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy
! http://www.cs.rice.edu/~keith/EMBED/dom.pdf
SYMBOL: idoms
: idom ( bb -- bb' ) idoms get at ;
<PRIVATE
: set-idom ( idom bb -- changed? ) idoms get maybe-set-at ;
: intersect ( finger1 finger2 -- bb )
2dup [ number>> ] compare {
{ +lt+ [ [ idom ] dip intersect ] }
{ +gt+ [ idom intersect ] }
[ 2drop ]
} case ;
: compute-idom ( bb -- idom )
predecessors>> [ idom ] map sift
[ ] [ intersect ] map-reduce ;
: iterate ( rpo -- changed? )
[ [ compute-idom ] keep set-idom ] map [ ] any? ;
PRIVATE>
: compute-dominance ( cfg -- cfg )
H{ } clone idoms set
dup reverse-post-order
unclip dup set-idom drop '[ _ iterate ] loop ;

1
basis/compiler/cfg/gc-checks/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

21
basis/compiler/cfg/gc-checks/gc-checks.factor Normal file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs
cpu.architecture compiler.cfg.rpo
compiler.cfg.liveness compiler.cfg.instructions
compiler.cfg.hats ;
IN: compiler.cfg.gc-checks
: gc? ( bb -- ? )
instructions>> [ ##allocation? ] any? ;
: object-pointer-regs ( basic-block -- vregs )
live-in keys [ reg-class>> int-regs eq? ] filter ;
: insert-gc-check ( basic-block -- )
dup gc? [
[ i i f f \ ##gc new-insn prefix ] change-instructions drop
] [ drop ] if ;
: insert-gc-checks ( cfg -- cfg' )
dup [ insert-gc-check ] each-basic-block ;

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

@ -73,3 +73,5 @@ 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
: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline

14
basis/compiler/cfg/height/height.factor
View File

@ -1,7 +1,8 @@
! 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: accessors math namespaces sequences kernel fry USING: accessors math namespaces sequences kernel fry
compiler.cfg compiler.cfg.registers compiler.cfg.instructions ; compiler.cfg compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.liveness compiler.cfg.local ;
IN: compiler.cfg.height IN: compiler.cfg.height
! Combine multiple stack height changes into one at the ! Combine multiple stack height changes into one at the
@ -42,10 +43,13 @@ M: ##replace normalize-height* normalize-peek/replace ;
M: insn normalize-height* ; M: insn normalize-height* ;
: normalize-height ( insns -- insns' ) : height-step ( insns -- insns' )
0 ds-height set 0 ds-height set
0 rs-height set 0 rs-height set
[ [ compute-heights ] each ] [ [ compute-heights ] each ]
[ [ [ normalize-height* ] map sift ] with-scope ] bi [ [ [ normalize-height* ] map sift ] with-scope ] bi
ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ; rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
: normalize-height ( cfg -- cfg' )
[ drop ] [ height-step ] local-optimization ;

38
basis/compiler/cfg/instructions/instructions.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: assocs accessors arrays kernel sequences namespaces words USING: assocs accessors arrays kernel sequences namespaces words
math math.order layouts classes.algebra alien byte-arrays math math.order layouts classes.algebra alien byte-arrays
@ -6,6 +6,8 @@ compiler.constants combinators compiler.cfg.registers
compiler.cfg.instructions.syntax ; compiler.cfg.instructions.syntax ;
IN: compiler.cfg.instructions IN: compiler.cfg.instructions
: new-insn ( ... class -- insn ) [ f f ] dip boa ; inline
! Virtual CPU instructions, used by CFG and machine IRs ! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: insn ; TUPLE: insn ;
@ -44,26 +46,19 @@ M: fixnum ##load-literal tag-fixnum ##load-immediate ;
M: f ##load-literal drop \ f tag-number ##load-immediate ; M: f ##load-literal drop \ f tag-number ##load-immediate ;
M: object ##load-literal ##load-reference ; M: object ##load-literal ##load-reference ;
INSN: ##peek < ##read { loc loc } ; INSN: ##peek < ##flushable { loc loc } ;
INSN: ##replace < ##write { loc loc } ; INSN: ##replace < ##effect { loc loc } ;
INSN: ##inc-d { n integer } ; INSN: ##inc-d { n integer } ;
INSN: ##inc-r { n integer } ; INSN: ##inc-r { n integer } ;
! Subroutine calls ! Subroutine calls
TUPLE: stack-frame
{ params integer }
{ return integer }
{ total-size integer }
spill-counts ;
INSN: ##stack-frame stack-frame ; INSN: ##stack-frame stack-frame ;
INSN: ##call word ; INSN: ##call word { height integer } ;
INSN: ##jump word ; INSN: ##jump word ;
INSN: ##return ; INSN: ##return ;
! Jump tables ! Jump tables
INSN: ##dispatch src temp offset ; INSN: ##dispatch src temp ;
INSN: ##dispatch-label label ;
! Slot access ! Slot access
INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ; INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
@ -160,9 +155,12 @@ INSN: ##set-alien-double < ##alien-setter ;
! Memory allocation ! Memory allocation
INSN: ##allot < ##flushable size class { temp vreg } ; INSN: ##allot < ##flushable size class { temp vreg } ;
UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
INSN: ##write-barrier < ##effect card# table ; INSN: ##write-barrier < ##effect card# table ;
INSN: ##alien-global < ##read symbol library ; INSN: ##alien-global < ##flushable symbol library ;
! FFI ! FFI
INSN: ##alien-invoke params ; INSN: ##alien-invoke params ;
@ -178,6 +176,8 @@ INSN: ##branch ;
INSN: ##loop-entry ; INSN: ##loop-entry ;
INSN: ##phi < ##pure inputs ;
! Condition codes ! Condition codes
SYMBOL: cc< SYMBOL: cc<
SYMBOL: cc<= SYMBOL: cc<=
@ -217,16 +217,19 @@ 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 ;
INSN: ##gc { temp1 vreg } { temp2 vreg } live-registers live-spill-slots ;
! Instructions used by machine IR only. ! Instructions used by machine IR only.
INSN: _prologue stack-frame ; INSN: _prologue stack-frame ;
INSN: _epilogue stack-frame ; INSN: _epilogue stack-frame ;
INSN: _label id ; INSN: _label id ;
INSN: _gc ;
INSN: _branch label ; INSN: _branch label ;
INSN: _dispatch src temp ;
INSN: _dispatch-label label ;
TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ; TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
INSN: _compare-branch < _conditional-branch ; INSN: _compare-branch < _conditional-branch ;
@ -234,8 +237,13 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
INSN: _compare-float-branch < _conditional-branch ; INSN: _compare-float-branch < _conditional-branch ;
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
! These instructions operate on machine registers and not ! These instructions operate on machine registers and not
! virtual registers ! virtual registers
INSN: _spill src class n ; INSN: _spill src class n ;
INSN: _reload dst class n ; INSN: _reload dst class n ;
INSN: _copy dst src class ;
INSN: _spill-counts counts ; INSN: _spill-counts counts ;

6
basis/compiler/cfg/instructions/syntax/syntax.factor
View File

@ -11,12 +11,12 @@ IN: compiler.cfg.instructions.syntax
"insn" "compiler.cfg.instructions" lookup ; "insn" "compiler.cfg.instructions" lookup ;
: insn-effect ( word -- effect ) : insn-effect ( word -- effect )
boa-effect in>> but-last f <effect> ; boa-effect in>> 2 head* f <effect> ;
SYNTAX: INSN: SYNTAX: INSN:
parse-tuple-definition "regs" suffix parse-tuple-definition { "regs" "insn#" } append
[ dup tuple eq? [ drop insn-word ] when ] dip [ dup tuple eq? [ drop insn-word ] when ] dip
[ define-tuple-class ] [ define-tuple-class ]
[ 2drop save-location ] [ 2drop save-location ]
[ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ] [ 2drop [ ] [ '[ f f _ boa , ] ] [ insn-effect ] tri define-inline ]
3tri ; 3tri ;

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

@ -37,9 +37,9 @@ DEFER: (tail-call?)
: tail-call? ( -- ? ) : tail-call? ( -- ? )
node-stack get [ node-stack get [
rest-slice rest-slice
[ t ] [ [ t ] [ (tail-call?) ] if-empty
[ (tail-call?) ]
[ first #terminate? not ]
bi and
] if-empty
] all? ; ] all? ;
: terminate-call? ( -- ? )
node-stack get last
rest-slice [ f ] [ first #terminate? ] if-empty ;

188
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -1,177 +1,41 @@
! 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 sequences math math.order kernel assocs USING: accessors assocs heaps kernel namespaces sequences
accessors vectors fry heaps cpu.architecture combinators compiler.cfg.linear-scan.allocation.coalescing
compiler.cfg.registers compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.allocation IN: compiler.cfg.linear-scan.allocation
! Mapping from register classes to sequences of machine registers
SYMBOL: free-registers
: free-registers-for ( vreg -- seq )
reg-class>> free-registers get at ;
: deallocate-register ( live-interval -- )
[ reg>> ] [ vreg>> ] bi free-registers-for push ;
! Vector of active live intervals
SYMBOL: active-intervals
: active-intervals-for ( vreg -- seq )
reg-class>> active-intervals get at ;
: add-active ( live-interval -- )
dup vreg>> active-intervals-for push ;
: delete-active ( live-interval -- )
dup vreg>> active-intervals-for delq ;
: expire-old-intervals ( n -- )
active-intervals swap '[
[
[ end>> _ < ] partition
[ [ deallocate-register ] each ] dip
] assoc-map
] change ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
! Start index of current live interval. We ensure that all
! live intervals added to the unhandled set have a start index
! strictly greater than ths one. This ensures that we can catch
! infinite loop situations.
SYMBOL: progress
: check-progress ( live-interval -- )
start>> progress get <= [ "No progress" throw ] when ; inline
: add-unhandled ( live-interval -- )
[ check-progress ]
[ dup start>> unhandled-intervals get heap-push ]
bi ;
: init-unhandled ( live-intervals -- )
[ [ start>> ] keep ] { } map>assoc
unhandled-intervals get heap-push-all ;
! Coalescing
: active-interval ( vreg -- live-interval )
dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
: coalesce? ( live-interval -- ? )
[ start>> ] [ copy-from>> active-interval ] bi
dup [ end>> = ] [ 2drop f ] if ;
: coalesce ( live-interval -- )
dup copy-from>> active-interval
[ [ add-active ] [ delete-active ] bi* ]
[ reg>> >>reg drop ]
2bi ;
! Splitting
: find-use ( live-interval n quot -- i elt )
[ uses>> ] 2dip curry find ; inline
: split-before ( live-interval i -- before )
[ clone dup uses>> ] dip
[ head >>uses ] [ 1- swap nth >>end ] 2bi ;
: split-after ( live-interval i -- after )
[ clone dup uses>> ] dip
[ tail >>uses ] [ swap nth >>start ] 2bi
f >>reg f >>copy-from ;
: split-interval ( live-interval n -- before after )
[ drop ] [ [ > ] find-use drop ] 2bi
[ split-before ] [ split-after ] 2bi ;
: record-split ( live-interval before after -- )
[ >>split-before ] [ >>split-after ] bi* drop ;
! Spilling
SYMBOL: spill-counts
: next-spill-location ( reg-class -- n )
spill-counts get [ dup 1+ ] change-at ;
: interval-to-spill ( active-intervals current -- live-interval )
#! We spill the interval with the most distant use location.
start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
[ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
: assign-spill ( before after -- before after )
#! If it has been spilled already, reuse spill location.
over reload-from>>
[ over vreg>> reg-class>> next-spill-location ] unless*
[ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
: split-and-spill ( new existing -- before after )
dup rot start>> split-interval
[ record-split ] [ assign-spill ] 2bi ;
: reuse-register ( new existing -- )
reg>> >>reg add-active ;
: spill-existing ( new existing -- )
#! Our new interval will be used before the active interval
#! with the most distant use location. Spill the existing
#! interval, then process the new interval and the tail end
#! of the existing interval again.
[ reuse-register ]
[ nip delete-active ]
[ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ;
: spill-new ( new existing -- )
#! Our new interval will be used after the active interval
#! with the most distant use location. Split the new
#! interval, then process both parts of the new interval
#! again.
[ dup split-and-spill add-unhandled ] dip spill-existing ;
: spill-existing? ( new existing -- ? )
#! Test if 'new' will be used before 'existing'.
over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
: assign-blocked-register ( new -- )
[ dup vreg>> active-intervals-for ] keep interval-to-spill
2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
: assign-free-register ( new registers -- )
pop >>reg add-active ;
: assign-register ( new -- ) : assign-register ( new -- )
dup coalesce? [ dup coalesce? [ coalesce ] [
coalesce dup vreg>> free-registers-for [
] [ dup intersecting-inactive
dup vreg>> free-registers-for
[ assign-blocked-register ] [ assign-blocked-register ]
[ assign-free-register ] [ assign-inactive-register ]
if-empty
] [ assign-free-register ]
if-empty if-empty
] if ; ] if ;
! Main loop
: reg-classes ( -- seq ) { int-regs double-float-regs } ; inline
: init-allocator ( registers -- )
<min-heap> unhandled-intervals set
[ reverse >vector ] assoc-map free-registers set
reg-classes [ 0 ] { } map>assoc spill-counts set
reg-classes [ V{ } clone ] { } map>assoc active-intervals set
-1 progress set ;
: handle-interval ( live-interval -- ) : handle-interval ( live-interval -- )
[ start>> progress set ] [
[ start>> expire-old-intervals ] start>>
[ assign-register ] [ progress set ]
tri ; [ deactivate-intervals ]
[ activate-intervals ] tri
] [ assign-register ] bi ;
: (allocate-registers) ( -- ) : (allocate-registers) ( -- )
unhandled-intervals get [ handle-interval ] slurp-heap ; unhandled-intervals get [ handle-interval ] slurp-heap ;
: finish-allocation ( -- )
active-intervals inactive-intervals
[ get values [ handled-intervals get push-all ] each ] bi@ ;
: allocate-registers ( live-intervals machine-registers -- live-intervals ) : allocate-registers ( live-intervals machine-registers -- live-intervals )
#! This modifies the input live-intervals.
init-allocator init-allocator
dup init-unhandled init-unhandled
(allocate-registers) ; (allocate-registers)
finish-allocation
handled-intervals get ;

18
basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor Normal file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences
compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.allocation.coalescing
: active-interval ( vreg -- live-interval )
dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
: coalesce? ( live-interval -- ? )
[ start>> ] [ copy-from>> active-interval ] bi
dup [ end>> = ] [ 2drop f ] if ;
: coalesce ( live-interval -- )
dup copy-from>> active-interval
[ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
[ reg>> >>reg drop ]
2bi ;

60
basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor Normal file
View File

@ -0,0 +1,60 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
math sequences sets sorting splitting
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.spilling
: split-for-spill ( live-interval n -- before after )
split-interval
[
[ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
[ [ ranges>> first ] [ uses>> first ] bi >>from drop ] bi*
]
[ [ compute-start/end ] bi@ ]
[ ]
2tri ;
: find-use ( live-interval n quot -- i elt )
[ uses>> ] 2dip curry find ; inline
: interval-to-spill ( active-intervals current -- live-interval )
#! We spill the interval with the most distant use location.
start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
[ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
: assign-spill ( before after -- before after )
#! If it has been spilled already, reuse spill location.
over reload-from>>
[ over vreg>> reg-class>> next-spill-location ] unless*
[ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
: split-and-spill ( new existing -- before after )
swap start>> split-for-spill assign-spill ;
: spill-existing ( new existing -- )
#! Our new interval will be used before the active interval
#! with the most distant use location. Spill the existing
#! interval, then process the new interval and the tail end
#! of the existing interval again.
[ reuse-register ]
[ nip delete-active ]
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
: spill-new ( new existing -- )
#! Our new interval will be used after the active interval
#! with the most distant use location. Split the new
#! interval, then process both parts of the new interval
#! again.
[ dup split-and-spill add-unhandled ] dip spill-existing ;
: spill-existing? ( new existing -- ? )
#! Test if 'new' will be used before 'existing'.
over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
: assign-blocked-register ( new -- )
[ dup vreg>> active-intervals-for ] keep interval-to-spill
2dup spill-existing? [ spill-existing ] [ spill-new ] if ;

120
basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor Normal file
View File

@ -0,0 +1,120 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
math sequences sets sorting splitting
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.splitting
: split-range ( live-range n -- before after )
[ [ from>> ] dip <live-range> ]
[ 1 + swap to>> <live-range> ]
2bi ;
: split-last-range? ( last n -- ? )
swap to>> <= ;
: split-last-range ( before after last n -- before' after' )
split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
: split-ranges ( live-ranges n -- before after )
[ '[ from>> _ <= ] partition ]
[
[ over last ] dip 2dup split-last-range?
[ split-last-range ] [ 2drop ] if
] bi ;
: split-uses ( uses n -- before after )
'[ _ <= ] partition ;
: record-split ( live-interval before after -- )
[ >>split-next drop ]
[ [ >>split-before ] [ >>split-after ] bi* drop ]
2bi ; inline
ERROR: splitting-too-early ;
ERROR: splitting-atomic-interval ;
: check-split ( live-interval n -- )
[ [ start>> ] dip > [ splitting-too-early ] when ]
[ drop [ end>> ] [ start>> ] bi - 0 = [ splitting-atomic-interval ] when ]
2bi ; inline
: split-before ( before -- before' )
f >>spill-to ; inline
: split-after ( after -- after' )
f >>copy-from f >>reg f >>reload-from ; inline
:: split-interval ( live-interval n -- before after )
live-interval n check-split
live-interval clone :> before
live-interval clone :> after
live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi*
live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi*
live-interval before after record-split
before split-before
after split-after ;
HINTS: split-interval live-interval object ;
: reuse-register ( new existing -- )
reg>> >>reg add-active ;
: relevant-ranges ( new inactive -- new' inactive' )
! Slice off all ranges of 'inactive' that precede the start of 'new'
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
: intersect-live-range ( range1 range2 -- n/f )
2dup [ from>> ] bi@ > [ swap ] when
2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
: intersect-live-ranges ( ranges1 ranges2 -- n )
{
{ [ over empty? ] [ 2drop 1/0. ] }
{ [ dup empty? ] [ 2drop 1/0. ] }
[
2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
drop
2dup [ first from>> ] bi@ <
[ [ rest-slice ] dip ] [ rest-slice ] if
intersect-live-ranges
] if
]
} cond ;
: intersect-inactive ( new inactive active-regs -- n/f )
! If the interval's register is currently in use, we cannot
! re-use it.
2dup [ reg>> ] dip key?
[ 3drop f ] [ drop relevant-ranges intersect-live-ranges ] if ;
: intersecting-inactive ( new -- live-intervals )
dup vreg>>
[ inactive-intervals-for ]
[ active-intervals-for [ reg>> ] map unique ] bi
'[ tuck _ intersect-inactive ] with { } map>assoc
[ nip ] assoc-filter ;
: insert-use-for-copy ( seq n -- seq' )
[ 1array split1 ] keep [ 1 - ] keep 2array glue ;
: split-before-use ( new n -- before after )
! Find optimal split position
! Insert move instruction
[ '[ _ insert-use-for-copy ] change-uses ] keep
1 - split-interval
2dup [ compute-start/end ] bi@ ;
: assign-inactive-register ( new live-intervals -- )
! If there is an interval which is inactive for the entire lifetime
! if the new interval, reuse its vreg. Otherwise, split new so that
! the first half fits.
sort-values last
2dup [ end>> ] [ second ] bi* < [
first reuse-register
] [
[ second split-before-use ] keep
'[ _ first reuse-register ] [ add-unhandled ] bi*
] if ;

134
basis/compiler/cfg/linear-scan/allocation/state/state.factor Normal file
View File

@ -0,0 +1,134 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators cpu.architecture fry heaps
kernel math namespaces sequences vectors
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.state
! Mapping from register classes to sequences of machine registers
SYMBOL: free-registers
: free-registers-for ( vreg -- seq )
reg-class>> free-registers get at ;
: deallocate-register ( live-interval -- )
[ reg>> ] [ vreg>> ] bi free-registers-for push ;
! Vector of active live intervals
SYMBOL: active-intervals
: active-intervals-for ( vreg -- seq )
reg-class>> active-intervals get at ;
: add-active ( live-interval -- )
dup vreg>> active-intervals-for push ;
: delete-active ( live-interval -- )
dup vreg>> active-intervals-for delq ;
: assign-free-register ( new registers -- )
pop >>reg add-active ;
! Vector of inactive live intervals
SYMBOL: inactive-intervals
: inactive-intervals-for ( vreg -- seq )
reg-class>> inactive-intervals get at ;
: add-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for push ;
! Vector of handled live intervals
SYMBOL: handled-intervals
: add-handled ( live-interval -- )
handled-intervals get push ;
: finished? ( n live-interval -- ? ) end>> swap < ;
: finish ( n live-interval -- keep? )
nip [ deallocate-register ] [ add-handled ] bi f ;
SYMBOL: check-allocation?
ERROR: register-already-used live-interval ;
: check-activate ( live-interval -- )
check-allocation? get [
dup [ reg>> ] [ vreg>> active-intervals-for [ reg>> ] map ] bi member?
[ register-already-used ] [ drop ] if
] [ drop ] if ;
: activate ( n live-interval -- keep? )
dup check-activate
nip add-active f ;
: deactivate ( n live-interval -- keep? )
nip add-inactive f ;
: don't-change ( n live-interval -- keep? ) 2drop t ;
! Moving intervals between active and inactive sets
: process-intervals ( n symbol quots -- )
! symbol stores an alist mapping register classes to vectors
[ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
: deactivate-intervals ( n -- )
! Any active intervals which have ended are moved to handled
! Any active intervals which cover the current position
! are moved to inactive
active-intervals {
{ [ 2dup finished? ] [ finish ] }
{ [ 2dup covers? not ] [ deactivate ] }
[ don't-change ]
} process-intervals ;
: activate-intervals ( n -- )
! Any inactive intervals which have ended are moved to handled
! Any inactive intervals which do not cover the current position
! are moved to active
inactive-intervals {
{ [ 2dup finished? ] [ finish ] }
{ [ 2dup covers? ] [ activate ] }
[ don't-change ]
} process-intervals ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
! Start index of current live interval. We ensure that all
! live intervals added to the unhandled set have a start index
! strictly greater than ths one. This ensures that we can catch
! infinite loop situations.
SYMBOL: progress
: check-progress ( live-interval -- )
start>> progress get <= [ "No progress" throw ] when ; inline
: add-unhandled ( live-interval -- )
[ check-progress ]
[ dup start>> unhandled-intervals get heap-push ]
bi ;
CONSTANT: reg-classes { int-regs double-float-regs }
: reg-class-assoc ( quot -- assoc )
[ reg-classes ] dip { } map>assoc ; inline
SYMBOL: spill-counts
: next-spill-location ( reg-class -- n )
spill-counts get [ dup 1 + ] change-at ;
: init-allocator ( registers -- )
[ reverse >vector ] assoc-map free-registers set
[ 0 ] reg-class-assoc spill-counts set
<min-heap> unhandled-intervals set
[ V{ } clone ] reg-class-assoc active-intervals set
[ V{ } clone ] reg-class-assoc inactive-intervals set
V{ } clone handled-intervals set
-1 progress set ;
: init-unhandled ( live-intervals -- )
[ [ start>> ] keep ] { } map>assoc
unhandled-intervals get heap-push-all ;

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

@ -1,4 +0,0 @@
USING: compiler.cfg.linear-scan.assignment tools.test ;
IN: compiler.cfg.linear-scan.assignment.tests

137
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -1,87 +1,144 @@
! 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: accessors kernel math assocs namespaces sequences heaps USING: accessors kernel math assocs namespaces sequences heaps
fry make combinators fry make combinators sets
cpu.architecture cpu.architecture
compiler.cfg.def-use compiler.cfg.def-use
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.assignment IN: compiler.cfg.linear-scan.assignment
! A vector of live intervals. There is linear searching involved ! This contains both active and inactive intervals; any interval
! but since we never have too many machine registers (around 30 ! such that start <= insn# <= end is in this set.
! at most) and we probably won't have that many live at any one SYMBOL: pending-intervals
! time anyway, it is not a problem to check each element.
SYMBOL: active-intervals
: add-active ( live-interval -- ) : add-active ( live-interval -- )
active-intervals get push ; pending-intervals get push ;
: lookup-register ( vreg -- reg )
active-intervals get [ vreg>> = ] with find nip reg>> ;
! Minheap of live intervals which still need a register allocation ! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals SYMBOL: unhandled-intervals
: add-unhandled ( live-interval -- ) : add-unhandled ( live-interval -- )
dup split-before>> [ dup start>> unhandled-intervals get heap-push ;
[ split-before>> ] [ split-after>> ] bi
[ add-unhandled ] bi@
] [
dup start>> unhandled-intervals get heap-push
] if ;
: init-unhandled ( live-intervals -- ) : init-unhandled ( live-intervals -- )
[ add-unhandled ] each ; [ add-unhandled ] each ;
! Mapping spill slots to vregs
SYMBOL: spill-slots
: spill-slots-for ( vreg -- assoc )
reg-class>> spill-slots get at ;
ERROR: already-spilled ;
: record-spill ( live-interval -- )
[ dup spill-to>> ] [ vreg>> spill-slots-for ] bi
2dup key? [ already-spilled ] [ set-at ] if ;
: insert-spill ( live-interval -- ) : insert-spill ( live-interval -- )
[ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
dup [ _spill ] [ 3drop ] if ;
: handle-spill ( live-interval -- )
dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
: insert-copy ( live-interval -- )
[ split-next>> reg>> ]
[ reg>> ]
[ vreg>> reg-class>> ]
tri _copy ;
: handle-copy ( live-interval -- )
dup [ spill-to>> not ] [ split-next>> ] bi and
[ insert-copy ] [ drop ] if ;
: expire-old-intervals ( n -- ) : expire-old-intervals ( n -- )
active-intervals get [ pending-intervals get ] dip '[
swap '[ end>> _ = ] partition dup end>> _ <
active-intervals set [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
[ insert-spill ] each ; ] filter-here ;
ERROR: already-reloaded ;
: record-reload ( live-interval -- )
[ reload-from>> ] [ vreg>> spill-slots-for ] bi
2dup key? [ delete-at ] [ already-reloaded ] if ;
: insert-reload ( live-interval -- ) : insert-reload ( live-interval -- )
[ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
dup [ _reload ] [ 3drop ] if ;
: handle-reload ( live-interval -- )
dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ;
: activate-new-intervals ( n -- ) : activate-new-intervals ( n -- )
#! Any live intervals which start on the current instruction #! Any live intervals which start on the current instruction
#! are added to the active set. #! are added to the active set.
unhandled-intervals get dup heap-empty? [ 2drop ] [ unhandled-intervals get dup heap-empty? [ 2drop ] [
2dup heap-peek drop start>> = [ 2dup heap-peek drop start>> = [
heap-pop drop [ add-active ] [ insert-reload ] bi heap-pop drop
[ add-active ] [ handle-reload ] bi
activate-new-intervals activate-new-intervals
] [ 2drop ] if ] [ 2drop ] if
] if ; ] if ;
GENERIC: (assign-registers) ( insn -- ) GENERIC: assign-registers-in-insn ( insn -- )
M: vreg-insn (assign-registers) : register-mapping ( live-intervals -- alist )
dup [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
[ defs-vregs ] [ uses-vregs ] bi append
active-intervals get swap '[ vreg>> _ member? ] filter : all-vregs ( insn -- vregs )
[ [ vreg>> ] [ reg>> ] bi ] { } map>assoc [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
: active-intervals ( insn -- intervals )
insn#>> pending-intervals get [ covers? ] with filter ;
M: vreg-insn assign-registers-in-insn
dup [ active-intervals ] [ all-vregs ] bi
'[ vreg>> _ member? ] filter
register-mapping
>>regs drop ; >>regs drop ;
M: insn (assign-registers) drop ; : compute-live-registers ( insn -- regs )
active-intervals register-mapping ;
: compute-live-spill-slots ( -- spill-slots )
spill-slots get values [ values ] map concat
[ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
M: ##gc assign-registers-in-insn
dup call-next-method
dup compute-live-registers >>live-registers
compute-live-spill-slots >>live-spill-slots
drop ;
M: insn assign-registers-in-insn drop ;
: init-assignment ( live-intervals -- ) : init-assignment ( live-intervals -- )
V{ } clone active-intervals set V{ } clone pending-intervals set
<min-heap> unhandled-intervals set <min-heap> unhandled-intervals set
[ H{ } clone ] reg-class-assoc spill-slots set
init-unhandled ; init-unhandled ;
: assign-registers ( insns live-intervals -- insns' ) : assign-registers-in-block ( bb -- )
[ [
init-assignment
[ [
[ activate-new-intervals ] [
[ drop [ (assign-registers) ] [ , ] bi ] [
insn#>>
[ expire-old-intervals ] [ expire-old-intervals ]
[ activate-new-intervals ]
bi
]
[ assign-registers-in-insn ]
[ , ]
tri tri
] each-index ] each
] { } make ; ] V{ } make
] change-instructions drop ;
: assign-registers ( rpo live-intervals -- )
init-assignment
[ assign-registers-in-block ] each ;

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

@ -1,15 +1,77 @@
IN: compiler.cfg.linear-scan.tests IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors kernel fry arrays splitting namespaces math accessors vectors locals
math.order grouping math.order grouping
cpu.architecture cpu.architecture
compiler.cfg
compiler.cfg.optimizer
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.liveness
compiler.cfg.predecessors
compiler.cfg.rpo
compiler.cfg.linear-scan compiler.cfg.linear-scan
compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.debugger ; compiler.cfg.linear-scan.debugger ;
check-allocation? on
[
{ T{ live-range f 1 10 } T{ live-range f 15 15 } }
{ T{ live-range f 16 20 } }
] [
{
T{ live-range f 1 10 }
T{ live-range f 15 20 }
} 15 split-ranges
] unit-test
[
{ T{ live-range f 1 10 } T{ live-range f 15 16 } }
{ T{ live-range f 17 20 } }
] [
{
T{ live-range f 1 10 }
T{ live-range f 15 20 }
} 16 split-ranges
] unit-test
[
{ T{ live-range f 1 10 } }
{ T{ live-range f 15 20 } }
] [
{
T{ live-range f 1 10 }
T{ live-range f 15 20 }
} 12 split-ranges
] unit-test
[
{ T{ live-range f 1 10 } T{ live-range f 15 17 } }
{ T{ live-range f 18 20 } }
] [
{
T{ live-range f 1 10 }
T{ live-range f 15 20 }
} 17 split-ranges
] unit-test
[
{ T{ live-range f 1 10 } } 0 split-ranges
] must-fail
[
{ T{ live-range f 0 0 } }
{ T{ live-range f 1 5 } }
] [
{ T{ live-range f 0 5 } } 0 split-ranges
] unit-test
[ 7 ] [ [ 7 ] [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } } { vreg T{ vreg { reg-class int-regs } { n 2 } } }
@ -46,12 +108,14 @@ compiler.cfg.linear-scan.debugger ;
{ start 0 } { start 0 }
{ end 1 } { end 1 }
{ uses V{ 0 1 } } { uses V{ 0 1 } }
{ ranges V{ T{ live-range f 0 1 } } }
} }
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 } { start 5 }
{ end 5 } { end 5 }
{ uses V{ 5 } } { uses V{ 5 } }
{ ranges V{ T{ live-range f 5 5 } } }
} }
] [ ] [
T{ live-interval T{ live-interval
@ -59,7 +123,8 @@ compiler.cfg.linear-scan.debugger ;
{ start 0 } { start 0 }
{ end 5 } { end 5 }
{ uses V{ 0 1 5 } } { uses V{ 0 1 5 } }
} 2 split-interval { ranges V{ T{ live-range f 0 5 } } }
} 2 split-for-spill [ f >>split-next ] bi@
] unit-test ] unit-test
[ [
@ -68,12 +133,14 @@ compiler.cfg.linear-scan.debugger ;
{ start 0 } { start 0 }
{ end 0 } { end 0 }
{ uses V{ 0 } } { uses V{ 0 } }
{ ranges V{ T{ live-range f 0 0 } } }
} }
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 } { start 1 }
{ end 5 } { end 5 }
{ uses V{ 1 5 } } { uses V{ 1 5 } }
{ ranges V{ T{ live-range f 1 5 } } }
} }
] [ ] [
T{ live-interval T{ live-interval
@ -81,7 +148,33 @@ compiler.cfg.linear-scan.debugger ;
{ start 0 } { start 0 }
{ end 5 } { end 5 }
{ uses V{ 0 1 5 } } { uses V{ 0 1 5 } }
} 0 split-interval { ranges V{ T{ live-range f 0 5 } } }
} 0 split-for-spill [ f >>split-next ] bi@
] unit-test
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 4 }
{ uses V{ 0 1 4 } }
{ ranges V{ T{ live-range f 0 4 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
{ ranges V{ T{ live-range f 5 5 } } }
}
] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } }
} 5 split-before-use [ f >>split-next ] bi@
] unit-test ] unit-test
[ [
@ -171,7 +264,13 @@ compiler.cfg.linear-scan.debugger ;
[ ] [ [ ] [
{ {
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } T{ live-interval
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
{ ranges V{ T{ live-range f 0 100 } } }
}
} }
H{ { int-regs { "A" } } } H{ { int-regs { "A" } } }
check-linear-scan check-linear-scan
@ -179,8 +278,20 @@ compiler.cfg.linear-scan.debugger ;
[ ] [ [ ] [
{ {
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 10 } { uses V{ 0 10 } } } T{ live-interval
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } } { vreg T{ vreg { n 1 } { reg-class int-regs } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 10 } }
{ ranges V{ T{ live-range f 0 10 } } }
}
T{ live-interval
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
{ start 11 }
{ end 20 }
{ uses V{ 11 20 } }
{ ranges V{ T{ live-range f 11 20 } } }
}
} }
H{ { int-regs { "A" } } } H{ { int-regs { "A" } } }
check-linear-scan check-linear-scan
@ -188,8 +299,20 @@ compiler.cfg.linear-scan.debugger ;
[ ] [ [ ] [
{ {
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } T{ live-interval
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } } { vreg T{ vreg { n 1 } { reg-class int-regs } } }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
{ start 30 }
{ end 60 }
{ uses V{ 30 60 } }
{ ranges V{ T{ live-range f 30 60 } } }
}
} }
H{ { int-regs { "A" } } } H{ { int-regs { "A" } } }
check-linear-scan check-linear-scan
@ -197,8 +320,20 @@ compiler.cfg.linear-scan.debugger ;
[ ] [ [ ] [
{ {
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } T{ live-interval
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } } { vreg T{ vreg { n 1 } { reg-class int-regs } } }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
{ start 30 }
{ end 200 }
{ uses V{ 30 200 } }
{ ranges V{ T{ live-range f 30 200 } } }
}
} }
H{ { int-regs { "A" } } } H{ { int-regs { "A" } } }
check-linear-scan check-linear-scan
@ -206,8 +341,20 @@ compiler.cfg.linear-scan.debugger ;
[ [
{ {
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } T{ live-interval
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 100 } } } { vreg T{ vreg { n 1 } { reg-class int-regs } } }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
{ start 30 }
{ end 100 }
{ uses V{ 30 100 } }
{ ranges V{ T{ live-range f 30 100 } } }
}
} }
H{ { int-regs { "A" } } } H{ { int-regs { "A" } } }
check-linear-scan check-linear-scan
@ -240,11 +387,12 @@ SYMBOL: max-uses
max-insns get [ 0 ] replicate taken set max-insns get [ 0 ] replicate taken set
max-insns get [ dup ] H{ } map>assoc available set max-insns get [ dup ] H{ } map>assoc available set
[ [
live-interval new \ live-interval new
swap int-regs swap vreg boa >>vreg swap int-regs swap vreg boa >>vreg
max-uses get random 2 max [ not-taken ] replicate natural-sort max-uses get random 2 max [ not-taken ] replicate natural-sort
[ >>uses ] [ first >>start ] bi [ >>uses ] [ first >>start ] bi
dup uses>> last >>end dup uses>> last >>end
dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
] map ] map
] with-scope ; ] with-scope ;
@ -264,45 +412,15 @@ SYMBOL: max-uses
USING: math.private compiler.cfg.debugger ; USING: math.private compiler.cfg.debugger ;
[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test [ ] [
[ float+ float>fixnum 3 fixnum*fast ]
[ f ] [ test-cfg first optimize-cfg linear-scan drop
T{ ##allot
f
T{ vreg f int-regs 1 }
40
array
T{ vreg f int-regs 2 }
f
} clone
1array (linear-scan) first regs>> values all-equal?
] unit-test ] unit-test
[ 0 1 ] [ : fake-live-ranges ( seq -- seq' )
{ [
T{ live-interval clone dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } ] map ;
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 3 }
{ end 4 }
{ uses V{ 3 4 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 2 }
{ end 6 }
{ uses V{ 2 4 6 } }
}
} [ clone ] map
H{ { int-regs { "A" "B" } } }
allocate-registers
first split-before>> [ start>> ] [ end>> ] bi
] unit-test
! Coalescing interacted badly with splitting ! Coalescing interacted badly with splitting
[ ] [ [ ] [
@ -351,7 +469,7 @@ USING: math.private compiler.cfg.debugger ;
{ end 10 } { end 10 }
{ uses V{ 9 10 } } { uses V{ 9 10 } }
} }
} } fake-live-ranges
{ { int-regs { 0 1 2 3 } } } { { int-regs { 0 1 2 3 } } }
allocate-registers drop allocate-registers drop
] unit-test ] unit-test
@ -1106,7 +1224,7 @@ USING: math.private compiler.cfg.debugger ;
{ end 109 } { end 109 }
{ uses V{ 103 109 } } { uses V{ 103 109 } }
} }
} } fake-live-ranges
{ { int-regs { 0 1 2 3 4 } } } { { int-regs { 0 1 2 3 4 } } }
allocate-registers drop allocate-registers drop
] unit-test ] unit-test
@ -1199,7 +1317,487 @@ USING: math.private compiler.cfg.debugger ;
{ end 92 } { end 92 }
{ uses V{ 42 45 78 80 92 } } { uses V{ 42 45 78 80 92 } }
} }
} } fake-live-ranges
{ { int-regs { 0 1 2 3 } } } { { int-regs { 0 1 2 3 } } }
allocate-registers drop allocate-registers drop
] unit-test ] unit-test
! Spill slot liveness was computed incorrectly, leading to a FEP
! early in bootstrap on x86-32
[ t ] [
[
H{ } clone live-ins set
H{ } clone live-outs set
H{ } clone phi-live-ins set
T{ basic-block
{ id 12345 }
{ instructions
V{
T{ ##gc f V int-regs 6 V int-regs 7 }
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f V int-regs 1 D 1 }
T{ ##peek f V int-regs 2 D 2 }
T{ ##peek f V int-regs 3 D 3 }
T{ ##peek f V int-regs 4 D 4 }
T{ ##peek f V int-regs 5 D 5 }
T{ ##replace f V int-regs 0 D 1 }
T{ ##replace f V int-regs 1 D 2 }
T{ ##replace f V int-regs 2 D 3 }
T{ ##replace f V int-regs 3 D 4 }
T{ ##replace f V int-regs 4 D 5 }
T{ ##replace f V int-regs 5 D 0 }
}
}
} dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
instructions>> first live-spill-slots>> empty?
] with-scope
] unit-test
[ f ] [
T{ live-range f 0 10 }
T{ live-range f 20 30 }
intersect-live-range
] unit-test
[ 10 ] [
T{ live-range f 0 10 }
T{ live-range f 10 30 }
intersect-live-range
] unit-test
[ 5 ] [
T{ live-range f 0 10 }
T{ live-range f 5 30 }
intersect-live-range
] unit-test
[ 5 ] [
T{ live-range f 5 30 }
T{ live-range f 0 10 }
intersect-live-range
] unit-test
[ 5 ] [
T{ live-range f 5 10 }
T{ live-range f 0 15 }
intersect-live-range
] unit-test
[ 50 ] [
{
T{ live-range f 0 10 }
T{ live-range f 20 30 }
T{ live-range f 40 50 }
}
{
T{ live-range f 11 15 }
T{ live-range f 31 35 }
T{ live-range f 50 55 }
}
intersect-live-ranges
] unit-test
[ 5 ] [
T{ live-interval
{ start 0 }
{ end 10 }
{ uses { 0 10 } }
{ ranges V{ T{ live-range f 0 10 } } }
}
T{ live-interval
{ start 5 }
{ end 10 }
{ uses { 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } }
}
H{ }
intersect-inactive
] unit-test
! Bug in live spill slots calculation
T{ basic-block
{ id 205651 }
{ number 0 }
{ instructions V{ T{ ##prologue } T{ ##branch } } }
} 0 set
T{ basic-block
{ id 205652 }
{ number 1 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 703128 }
{ loc D 1 }
}
T{ ##peek
{ dst V int-regs 703129 }
{ loc D 0 }
}
T{ ##copy
{ dst V int-regs 703134 }
{ src V int-regs 703128 }
}
T{ ##copy
{ dst V int-regs 703135 }
{ src V int-regs 703129 }
}
T{ ##compare-imm-branch
{ src1 V int-regs 703128 }
{ src2 5 }
{ cc cc/= }
}
}
}
} 1 set
T{ basic-block
{ id 205653 }
{ number 2 }
{ instructions
V{
T{ ##copy
{ dst V int-regs 703134 }
{ src V int-regs 703129 }
}
T{ ##copy
{ dst V int-regs 703135 }
{ src V int-regs 703128 }
}
T{ ##branch }
}
}
} 2 set
T{ basic-block
{ id 205655 }
{ number 3 }
{ instructions
V{
T{ ##replace
{ src V int-regs 703134 }
{ loc D 0 }
}
T{ ##replace
{ src V int-regs 703135 }
{ loc D 1 }
}
T{ ##epilogue }
T{ ##return }
}
}
} 3 set
1 get 1vector 0 get (>>successors)
2 get 3 get V{ } 2sequence 1 get (>>successors)
3 get 1vector 2 get (>>successors)
:: test-linear-scan-on-cfg ( regs -- )
[ ] [
cfg new 0 get >>entry
compute-predecessors
compute-liveness
reverse-post-order
{ { int-regs regs } } (linear-scan)
] unit-test ;
{ 1 2 } test-linear-scan-on-cfg
! Bug in inactive interval handling
! [ rot dup [ -rot ] when ]
T{ basic-block
{ id 201486 }
{ number 0 }
{ instructions V{ T{ ##prologue } T{ ##branch } } }
} 0 set
T{ basic-block
{ id 201487 }
{ number 1 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 689473 }
{ loc D 2 }
}
T{ ##peek
{ dst V int-regs 689474 }
{ loc D 1 }
}
T{ ##peek
{ dst V int-regs 689475 }
{ loc D 0 }
}
T{ ##compare-imm-branch
{ src1 V int-regs 689473 }
{ src2 5 }
{ cc cc/= }
}
}
}
} 1 set
T{ basic-block
{ id 201488 }
{ number 2 }
{ instructions
V{
T{ ##copy
{ dst V int-regs 689481 }
{ src V int-regs 689475 }
}
T{ ##copy
{ dst V int-regs 689482 }
{ src V int-regs 689474 }
}
T{ ##copy
{ dst V int-regs 689483 }
{ src V int-regs 689473 }
}
T{ ##branch }
}
}
} 2 set
T{ basic-block
{ id 201489 }
{ number 3 }
{ instructions
V{
T{ ##copy
{ dst V int-regs 689481 }
{ src V int-regs 689473 }
}
T{ ##copy
{ dst V int-regs 689482 }
{ src V int-regs 689475 }
}
T{ ##copy
{ dst V int-regs 689483 }
{ src V int-regs 689474 }
}
T{ ##branch }
}
}
} 3 set
T{ basic-block
{ id 201490 }
{ number 4 }
{ instructions
V{
T{ ##replace
{ src V int-regs 689481 }
{ loc D 0 }
}
T{ ##replace
{ src V int-regs 689482 }
{ loc D 1 }
}
T{ ##replace
{ src V int-regs 689483 }
{ loc D 2 }
}
T{ ##epilogue }
T{ ##return }
}
}
} 4 set
: test-diamond ( -- )
1 get 1vector 0 get (>>successors)
2 get 3 get V{ } 2sequence 1 get (>>successors)
4 get 1vector 2 get (>>successors)
4 get 1vector 3 get (>>successors) ;
test-diamond
{ 1 2 3 4 } test-linear-scan-on-cfg
! Similar to the above
! [ swap dup [ rot ] when ]
T{ basic-block
{ id 201537 }
{ number 0 }
{ instructions V{ T{ ##prologue } T{ ##branch } } }
} 0 set
T{ basic-block
{ id 201538 }
{ number 1 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 689600 }
{ loc D 1 }
}
T{ ##peek
{ dst V int-regs 689601 }
{ loc D 0 }
}
T{ ##compare-imm-branch
{ src1 V int-regs 689600 }
{ src2 5 }
{ cc cc/= }
}
}
}
} 1 set
T{ basic-block
{ id 201539 }
{ number 2 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 689604 }
{ loc D 2 }
}
T{ ##copy
{ dst V int-regs 689607 }
{ src V int-regs 689604 }
}
T{ ##copy
{ dst V int-regs 689608 }
{ src V int-regs 689600 }
}
T{ ##copy
{ dst V int-regs 689610 }
{ src V int-regs 689601 }
}
T{ ##branch }
}
}
} 2 set
T{ basic-block
{ id 201540 }
{ number 3 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 689609 }
{ loc D 2 }
}
T{ ##copy
{ dst V int-regs 689607 }
{ src V int-regs 689600 }
}
T{ ##copy
{ dst V int-regs 689608 }
{ src V int-regs 689601 }
}
T{ ##copy
{ dst V int-regs 689610 }
{ src V int-regs 689609 }
}
T{ ##branch }
}
}
} 3 set
T{ basic-block
{ id 201541 }
{ number 4 }
{ instructions
V{
T{ ##replace
{ src V int-regs 689607 }
{ loc D 0 }
}
T{ ##replace
{ src V int-regs 689608 }
{ loc D 1 }
}
T{ ##replace
{ src V int-regs 689610 }
{ loc D 2 }
}
T{ ##epilogue }
T{ ##return }
}
}
} 4 set
test-diamond
{ 1 2 3 4 } test-linear-scan-on-cfg
! compute-live-registers was inaccurate since it didn't take
! lifetime holes into account
T{ basic-block
{ id 0 }
{ number 0 }
{ instructions V{ T{ ##prologue } T{ ##branch } } }
} 0 set
T{ basic-block
{ id 1 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 0 }
{ loc D 0 }
}
T{ ##compare-imm-branch
{ src1 V int-regs 0 }
{ src2 5 }
{ cc cc/= }
}
}
}
} 1 set
T{ basic-block
{ id 2 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 1 }
{ loc D 1 }
}
T{ ##copy
{ dst V int-regs 2 }
{ src V int-regs 1 }
}
T{ ##branch }
}
}
} 2 set
T{ basic-block
{ id 3 }
{ instructions
V{
T{ ##peek
{ dst V int-regs 3 }
{ loc D 2 }
}
T{ ##copy
{ dst V int-regs 2 }
{ src V int-regs 3 }
}
T{ ##branch }
}
}
} 3 set
T{ basic-block
{ id 4 }
{ instructions
V{
T{ ##replace
{ src V int-regs 2 }
{ loc D 0 }
}
T{ ##return }
}
}
} 4 set
test-diamond
{ 1 2 3 4 } test-linear-scan-on-cfg

22
basis/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -1,11 +1,14 @@
! 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: kernel accessors namespaces make USING: kernel accessors namespaces make
cpu.architecture cpu.architecture
compiler.cfg compiler.cfg
compiler.cfg.rpo
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.assignment ; compiler.cfg.linear-scan.assignment ;
IN: compiler.cfg.linear-scan IN: compiler.cfg.linear-scan
@ -23,16 +26,15 @@ IN: compiler.cfg.linear-scan
! by Omri Traub, Glenn Holloway, Michael D. Smith ! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
: (linear-scan) ( insns -- insns' ) : (linear-scan) ( rpo machine-registers -- )
[
dup number-instructions
dup compute-live-intervals dup compute-live-intervals
machine-registers allocate-registers assign-registers ; ] dip
allocate-registers assign-registers ;
: linear-scan ( mr -- mr' ) : linear-scan ( cfg -- cfg' )
[ [
[ dup reverse-post-order machine-registers (linear-scan)
[ spill-counts get >>spill-counts
(linear-scan) %
spill-counts get _spill-counts
] { } make
] change-instructions
] with-scope ; ] with-scope ;

142
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -1,26 +1,65 @@
! 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 kernel assocs accessors sequences math fry USING: namespaces kernel assocs accessors sequences math math.order fry
compiler.cfg.instructions compiler.cfg.registers binary-search combinators compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.def-use ; compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
IN: compiler.cfg.linear-scan.live-intervals IN: compiler.cfg.linear-scan.live-intervals
TUPLE: live-range from to ;
C: <live-range> live-range
TUPLE: live-interval TUPLE: live-interval
vreg vreg
reg spill-to reload-from split-before split-after reg spill-to reload-from
start end uses split-before split-after split-next
start end ranges uses
copy-from ; copy-from ;
: add-use ( n live-interval -- ) : covers? ( insn# live-interval -- ? )
dup live-interval? [ "No def" throw ] unless ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
[ (>>end) ] [ uses>> push ] 2bi ;
: <live-interval> ( start vreg -- live-interval ) : child-interval-at ( insn# interval -- interval' )
live-interval new dup split-after>> [
2dup split-after>> start>> <
[ split-before>> ] [ split-after>> ] if
child-interval-at
] [ nip ] if ;
ERROR: dead-value-error vreg ;
: shorten-range ( n live-interval -- )
dup ranges>> empty?
[ vreg>> dead-value-error ] [ ranges>> last (>>from) ] if ;
: extend-range ( from to live-range -- )
ranges>> last
[ max ] change-to
[ min ] change-from
drop ;
: add-new-range ( from to live-interval -- )
[ <live-range> ] dip ranges>> push ;
: extend-range? ( to live-interval -- ? )
ranges>> [ drop f ] [ last from>> >= ] if-empty ;
: add-range ( from to live-interval -- )
2dup extend-range?
[ extend-range ] [ add-new-range ] if ;
: add-use ( n live-interval -- )
uses>> push ;
: <live-interval> ( vreg -- live-interval )
\ live-interval new
V{ } clone >>uses V{ } clone >>uses
swap >>vreg V{ } clone >>ranges
over >>start swap >>vreg ;
[ add-use ] keep ;
: block-from ( bb -- n ) instructions>> first insn#>> ;
: block-to ( bb -- n ) instructions>> last insn#>> ;
M: live-interval hashcode* M: live-interval hashcode*
nip [ start>> ] [ end>> 1000 * ] bi + ; nip [ start>> ] [ end>> 1000 * ] bi + ;
@ -31,34 +70,77 @@ M: live-interval clone
! Mapping from vreg to live-interval ! Mapping from vreg to live-interval
SYMBOL: live-intervals SYMBOL: live-intervals
: new-live-interval ( n vreg live-intervals -- ) : live-interval ( vreg live-intervals -- live-interval )
2dup key? [ [ <live-interval> ] cache ;
at add-use
] [
[ [ <live-interval> ] keep ] dip set-at
] if ;
GENERIC# compute-live-intervals* 1 ( insn n -- ) GENERIC: compute-live-intervals* ( insn -- )
M: insn compute-live-intervals* 2drop ; M: insn compute-live-intervals* drop ;
: handle-output ( n vreg live-intervals -- )
live-interval
[ add-use ] [ shorten-range ] 2bi ;
: handle-input ( n vreg live-intervals -- )
live-interval
[ [ basic-block get block-from ] 2dip add-range ] [ add-use ] 2bi ;
: handle-temp ( n vreg live-intervals -- )
live-interval
[ dupd add-range ] [ add-use ] 2bi ;
M: vreg-insn compute-live-intervals* M: vreg-insn compute-live-intervals*
dup insn#>>
live-intervals get live-intervals get
[ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ] [ [ defs-vregs ] 2dip '[ [ _ ] dip _ handle-output ] each ]
[ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ] [ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ]
3bi ; [ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
3tri ;
: record-copy ( insn -- ) : record-copy ( insn -- )
[ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ; [ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
M: ##copy compute-live-intervals* M: ##copy compute-live-intervals*
[ call-next-method ] [ drop record-copy ] 2bi ; [ call-next-method ] [ record-copy ] bi ;
M: ##copy-float compute-live-intervals* M: ##copy-float compute-live-intervals*
[ call-next-method ] [ drop record-copy ] 2bi ; [ call-next-method ] [ record-copy ] bi ;
: compute-live-intervals ( instructions -- live-intervals ) : handle-live-out ( bb -- )
live-out keys
basic-block get [ block-from ] [ block-to ] bi
live-intervals get '[
[ _ _ ] dip _ live-interval add-range
] each ;
: compute-live-intervals-step ( bb -- )
[ basic-block set ]
[ handle-live-out ]
[ instructions>> <reversed> [ compute-live-intervals* ] each ] tri ;
: compute-start/end ( live-interval -- )
dup ranges>> [ first from>> ] [ last to>> ] bi
[ >>start ] [ >>end ] bi* drop ;
: check-start/end ( live-interval -- )
[ [ start>> ] [ uses>> first ] bi assert= ]
[ [ end>> ] [ uses>> last ] bi assert= ]
bi ;
: finish-live-intervals ( live-intervals -- )
! Since live intervals are computed in a backward order, we have
! to reverse some sequences, and compute the start and end.
[
{
[ ranges>> reverse-here ]
[ uses>> reverse-here ]
[ compute-start/end ]
[ check-start/end ]
} cleave
] each ;
: compute-live-intervals ( rpo -- live-intervals )
H{ } clone [ H{ } clone [
live-intervals set live-intervals set
[ compute-live-intervals* ] each-index <reversed> [ compute-live-intervals-step ] each
] keep values ; ] keep values dup finish-live-intervals ;

1
basis/compiler/cfg/linear-scan/numbering/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

11
basis/compiler/cfg/linear-scan/numbering/numbering.factor Normal file
View File

@ -0,0 +1,11 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math sequences ;
IN: compiler.cfg.linear-scan.numbering
: number-instructions ( rpo -- )
[ 0 ] dip [
instructions>> [
[ (>>insn#) ] [ drop 2 + ] 2bi
] each
] each drop ;

34
basis/compiler/cfg/linear-scan/resolve/resolve.factor Normal file
View File

@ -0,0 +1,34 @@
! Copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math namespaces sequences
compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness ;
IN: compiler.cfg.linear-scan.resolve
: add-mapping ( from to -- )
2drop
;
: resolve-value-data-flow ( bb to vreg -- )
live-intervals get at
[ [ block-to ] dip child-interval-at ]
[ [ block-from ] dip child-interval-at ]
bi-curry bi* 2dup = [ 2drop ] [
add-mapping
] if ;
: resolve-mappings ( bb to -- )
2drop
;
: resolve-edge-data-flow ( bb to -- )
[ 2dup live-in [ resolve-value-data-flow ] with with each ]
[ resolve-mappings ]
2bi ;
: resolve-block-data-flow ( bb -- )
dup successors>> [
resolve-edge-data-flow
] with each ;
: resolve-data-flow ( rpo -- )
[ resolve-block-data-flow ] each ;

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

@ -1,24 +1,28 @@
! 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: kernel math accessors sequences namespaces make USING: kernel math accessors sequences namespaces make
combinators classes combinators assocs arrays locals cpu.architecture
compiler.cfg compiler.cfg
compiler.cfg.rpo compiler.cfg.rpo
compiler.cfg.liveness
compiler.cfg.stack-frame
compiler.cfg.instructions ; compiler.cfg.instructions ;
IN: compiler.cfg.linearization IN: compiler.cfg.linearization
! Convert CFG IR to machine IR. ! Convert CFG IR to machine IR.
GENERIC: linearize-insn ( basic-block insn -- ) GENERIC: linearize-insn ( basic-block insn -- )
: linearize-insns ( basic-block -- ) : linearize-basic-block ( bb -- )
dup instructions>> [ linearize-insn ] with each ; inline [ number>> _label ]
[ dup instructions>> [ linearize-insn ] with each ]
bi ;
M: insn linearize-insn , drop ; M: insn linearize-insn , drop ;
: useless-branch? ( basic-block successor -- ? ) : useless-branch? ( basic-block successor -- ? )
#! If our successor immediately follows us in RPO, then we #! If our successor immediately follows us in RPO, then we
#! don't need to branch. #! don't need to branch.
[ number>> ] bi@ 1- = ; inline [ number>> ] bi@ 1 - = ; inline
: branch-to-branch? ( successor -- ? ) : branch-to-branch? ( successor -- ? )
#! A branch to a block containing just a jump return is cloned. #! A branch to a block containing just a jump return is cloned.
@ -30,7 +34,7 @@ M: insn linearize-insn , drop ;
: emit-branch ( basic-block successor -- ) : emit-branch ( basic-block successor -- )
{ {
{ [ 2dup useless-branch? ] [ 2drop ] } { [ 2dup useless-branch? ] [ 2drop ] }
{ [ dup branch-to-branch? ] [ nip linearize-insns ] } { [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
[ nip number>> _branch ] [ nip number>> _branch ]
} cond ; } cond ;
@ -46,35 +50,82 @@ M: ##branch linearize-insn
[ drop dup successors>> second useless-branch? ] 2bi [ drop dup successors>> second useless-branch? ] 2bi
[ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ; [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
: with-regs ( insn quot -- )
over regs>> [ call ] dip building get last (>>regs) ; inline
M: ##compare-branch linearize-insn M: ##compare-branch linearize-insn
binary-conditional _compare-branch emit-branch ; [ binary-conditional _compare-branch ] with-regs emit-branch ;
M: ##compare-imm-branch linearize-insn M: ##compare-imm-branch linearize-insn
binary-conditional _compare-imm-branch emit-branch ; [ binary-conditional _compare-imm-branch ] with-regs emit-branch ;
M: ##compare-float-branch linearize-insn M: ##compare-float-branch linearize-insn
binary-conditional _compare-float-branch emit-branch ; [ binary-conditional _compare-float-branch ] with-regs emit-branch ;
: gc? ( bb -- ? ) M: ##dispatch linearize-insn
instructions>> [ swap
class { [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
##allot [ successors>> [ number>> _dispatch-label ] each ]
##integer>bignum bi* ;
##box-float
##box-alien
} memq?
] any? ;
: linearize-basic-block ( bb -- ) : gc-root-registers ( n live-registers -- n )
[ number>> _label ] [
[ gc? [ _gc ] when ] [ second 2array , ]
[ linearize-insns ] [ first reg-class>> reg-size + ]
tri ; 2bi
] each ;
: linearize-basic-blocks ( rpo -- insns ) : gc-root-spill-slots ( n live-spill-slots -- n )
[ [ linearize-basic-block ] each ] { } make ; [
dup first reg-class>> int-regs eq? [
[ second <spill-slot> 2array , ]
[ first reg-class>> reg-size + ]
2bi
] [ drop ] if
] each ;
: build-mr ( cfg -- mr ) : oop-registers ( regs -- regs' )
[ entry>> reverse-post-order linearize-basic-blocks ] [ first reg-class>> int-regs eq? ] filter ;
[ word>> ] [ label>> ]
tri <mr> ; : data-registers ( regs -- regs' )
[ first reg-class>> double-float-regs eq? ] filter ;
:: compute-gc-roots ( live-registers live-spill-slots -- alist )
[
0
! we put float registers last; the GC doesn't actually scan them
live-registers oop-registers gc-root-registers
live-spill-slots gc-root-spill-slots
live-registers data-registers gc-root-registers
drop
] { } make ;
: count-gc-roots ( live-registers live-spill-slots -- n )
! Size of GC root area, minus the float registers
[ oop-registers length ] bi@ + ;
M: ##gc linearize-insn
nip
[
[ temp1>> ]
[ temp2>> ]
[
[ live-registers>> ] [ live-spill-slots>> ] bi
[ compute-gc-roots ]
[ count-gc-roots ]
[ gc-roots-size ]
2tri
] tri
_gc
] with-regs ;
: linearize-basic-blocks ( cfg -- insns )
[
[ [ linearize-basic-block ] each-basic-block ]
[ spill-counts>> _spill-counts ]
bi
] { } make ;
: flatten-cfg ( cfg -- mr )
[ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
<mr> ;

1
basis/compiler/cfg/liveness/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

78
basis/compiler/cfg/liveness/liveness.factor Normal file
View File

@ -0,0 +1,78 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces deques accessors sets sequences assocs fry
dlists compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.rpo ;
IN: compiler.cfg.liveness
! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis
! Assoc mapping basic blocks to sets of vregs
SYMBOL: live-ins
: live-in ( basic-block -- set ) live-ins get at ;
! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
! is in conrrespondence with a predecessor
SYMBOL: phi-live-ins
: phi-live-in ( predecessor basic-block -- set )
[ predecessors>> index ] keep phi-live-ins get at
dup [ nth ] [ 2drop f ] if ;
! Assoc mapping basic blocks to sets of vregs
SYMBOL: live-outs
: live-out ( basic-block -- set ) live-outs get at ;
SYMBOL: work-list
: add-to-work-list ( basic-blocks -- )
work-list get '[ _ push-front ] each ;
: map-unique ( seq quot -- assoc )
map concat unique ; inline
: gen-set ( instructions -- seq )
[ ##phi? not ] filter [ uses-vregs ] map-unique ;
: kill-set ( instructions -- seq )
[ [ defs-vregs ] [ temp-vregs ] bi append ] map-unique ;
: compute-live-in ( basic-block -- live-in )
dup instructions>>
[ [ live-out ] [ gen-set ] bi* assoc-union ]
[ nip kill-set ]
2bi assoc-diff ;
: compute-phi-live-in ( basic-block -- phi-live-in )
instructions>> [ ##phi? ] filter
[ f ] [ [ inputs>> ] map flip [ unique ] map ] if-empty ;
: update-live-in ( basic-block -- changed? )
[ [ compute-live-in ] keep live-ins get maybe-set-at ]
[ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
bi and ;
: compute-live-out ( basic-block -- live-out )
[ successors>> [ live-in ] map ]
[ dup successors>> [ phi-live-in ] with map ] bi
append assoc-combine ;
: update-live-out ( basic-block -- changed? )
[ compute-live-out ] keep
live-outs get maybe-set-at ;
: liveness-step ( basic-block -- )
dup update-live-out [
dup update-live-in
[ predecessors>> add-to-work-list ] [ drop ] if
] [ drop ] if ;
: compute-liveness ( cfg -- cfg' )
<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
work-list get [ liveness-step ] slurp-deque ;

1
basis/compiler/cfg/local/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

10
basis/compiler/cfg/local/local.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel assocs compiler.cfg.liveness compiler.cfg.rpo ;
IN: compiler.cfg.local
: optimize-basic-block ( bb init-quot insn-quot -- )
[ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
[ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; inline

1
basis/compiler/cfg/mr/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

14
basis/compiler/cfg/mr/mr.factor Normal file
View File

@ -0,0 +1,14 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.cfg.linearization compiler.cfg.two-operand
compiler.cfg.liveness compiler.cfg.gc-checks compiler.cfg.linear-scan
compiler.cfg.build-stack-frame compiler.cfg.rpo ;
IN: compiler.cfg.mr
: build-mr ( cfg -- mr )
convert-two-operand
compute-liveness
insert-gc-checks
linear-scan
flatten-cfg
build-stack-frame ;

34
basis/compiler/cfg/optimizer/optimizer-tests.factor Normal file
View File

@ -0,0 +1,34 @@
USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors
sequences.private math sbufs math.private slots.private strings ;
IN: compiler.cfg.optimizer.tests
! Miscellaneous tests
: more? ( x -- ? ) ;
: test-case-1 ( -- ? ) f ;
: test-case-2 ( -- )
test-case-1 [ test-case-2 ] [ ] if ; inline recursive
{
[ 1array ]
[ 1 2 ? ]
[ { array } declare [ ] map ]
[ { array } declare dup 1 slot [ 1 slot ] when ]
[ [ dup more? ] [ dup ] produce ]
[ vector new over test-case-1 [ test-case-2 ] [ ] if ]
[ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
[
{ fixnum sbuf } declare 2dup 3 slot fixnum> [
over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
] [ ] if
]
[ [ 2 fixnum* ] when 3 ]
[ [ 2 fixnum+ ] when 3 ]
[ [ 2 fixnum- ] when 3 ]
[ 10000 [ ] times ]
} [
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
] each

32
basis/compiler/cfg/optimizer/optimizer.factor
View File

@ -1,29 +1,39 @@
! 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: kernel sequences compiler.cfg.rpo USING: kernel sequences accessors combinators namespaces
compiler.cfg.instructions
compiler.cfg.predecessors compiler.cfg.predecessors
compiler.cfg.useless-blocks compiler.cfg.useless-blocks
compiler.cfg.height compiler.cfg.height
compiler.cfg.stack-analysis
compiler.cfg.alias-analysis compiler.cfg.alias-analysis
compiler.cfg.value-numbering compiler.cfg.value-numbering
compiler.cfg.dead-code compiler.cfg.dce
compiler.cfg.write-barrier ; compiler.cfg.write-barrier
compiler.cfg.liveness
compiler.cfg.rpo
compiler.cfg.phi-elimination
compiler.cfg.checker ;
IN: compiler.cfg.optimizer IN: compiler.cfg.optimizer
: trivial? ( insns -- ? ) SYMBOL: check-optimizer?
dup length 2 = [ first ##call? ] [ drop f ] if ;
: ?check ( cfg -- cfg' )
check-optimizer? get [
dup check-cfg
] when ;
: optimize-cfg ( cfg -- cfg' ) : optimize-cfg ( cfg -- cfg' )
[
compute-predecessors compute-predecessors
delete-useless-blocks delete-useless-blocks
delete-useless-conditionals delete-useless-conditionals
[
dup trivial? [
normalize-height normalize-height
stack-analysis
compute-liveness
alias-analysis alias-analysis
value-numbering value-numbering
eliminate-dead-code eliminate-dead-code
eliminate-write-barriers eliminate-write-barriers
] unless eliminate-phis
] change-basic-blocks ; ?check
] with-scope ;

1
basis/compiler/cfg/phi-elimination/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

21
basis/compiler/cfg/phi-elimination/phi-elimination.factor Normal file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors compiler.cfg compiler.cfg.instructions
compiler.cfg.rpo fry kernel sequences ;
IN: compiler.cfg.phi-elimination
: insert-copy ( predecessor input output -- )
'[ _ _ swap ##copy ] add-instructions ;
: eliminate-phi ( bb ##phi -- )
[ predecessors>> ] [ [ inputs>> ] [ dst>> ] bi ] bi*
'[ _ insert-copy ] 2each ;
: eliminate-phi-step ( bb -- )
dup [
[ ##phi? ] partition
[ [ eliminate-phi ] with each ] dip
] change-instructions drop ;
: eliminate-phis ( cfg -- cfg' )
dup [ eliminate-phi-step ] each-basic-block ;

9
basis/compiler/cfg/predecessors/predecessors.factor
View File

@ -1,10 +1,13 @@
! 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: kernel accessors sequences compiler.cfg.rpo ; USING: kernel accessors sequences compiler.cfg.rpo ;
IN: compiler.cfg.predecessors IN: compiler.cfg.predecessors
: (compute-predecessors) ( bb -- ) : predecessors-step ( bb -- )
dup successors>> [ predecessors>> push ] with each ; dup successors>> [ predecessors>> push ] with each ;
: compute-predecessors ( cfg -- cfg' ) : compute-predecessors ( cfg -- cfg' )
dup [ (compute-predecessors) ] each-basic-block ; [ [ V{ } clone >>predecessors drop ] each-basic-block ]
[ [ predecessors-step ] each-basic-block ]
[ ]
tri ;

34
basis/compiler/cfg/rpo/rpo.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: kernel accessors namespaces make math sequences sets USING: kernel accessors namespaces make math sequences sets
assocs fry compiler.cfg compiler.cfg.instructions ; assocs fry compiler.cfg compiler.cfg.instructions ;
@ -7,29 +7,29 @@ IN: compiler.cfg.rpo
SYMBOL: visited SYMBOL: visited
: post-order-traversal ( bb -- ) : post-order-traversal ( bb -- )
dup id>> visited get key? [ drop ] [ dup visited get key? [ drop ] [
dup id>> visited get conjoin dup visited get conjoin
[ [
successors>> <reversed> successors>> <reversed>
[ post-order-traversal ] each [ post-order-traversal ] each
] [ , ] bi ] [ , ] bi
] if ; ] if ;
: post-order ( bb -- blocks )
[ post-order-traversal ] { } make ;
: number-blocks ( blocks -- ) : number-blocks ( blocks -- )
[ >>number drop ] each-index ; dup length iota <reversed>
[ >>number drop ] 2each ;
: reverse-post-order ( bb -- blocks ) : post-order ( cfg -- blocks )
H{ } clone visited [ dup post-order>> [ ] [
post-order <reversed> dup number-blocks [
] with-variable ; inline H{ } clone visited set
dup entry>> post-order-traversal
] { } make dup number-blocks
>>post-order post-order>>
] ?if ;
: reverse-post-order ( cfg -- blocks )
post-order <reversed> ; inline
: each-basic-block ( cfg quot -- ) : each-basic-block ( cfg quot -- )
[ entry>> reverse-post-order ] dip each ; inline [ reverse-post-order ] dip each ; inline
: change-basic-blocks ( cfg quot -- cfg' )
[ '[ _ change-instructions drop ] each-basic-block ]
[ drop ]
2bi ; inline

1
basis/compiler/cfg/stack-analysis/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

115
basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor Normal file
View File

@ -0,0 +1,115 @@
USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization
compiler.cfg.predecessors compiler.cfg.stack-analysis
compiler.cfg.instructions sequences kernel tools.test accessors
sequences.private alien math combinators.private compiler.cfg
compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo
compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
sets namespaces ;
IN: compiler.cfg.stack-analysis.tests
! Fundamental invariant: a basic block should not load or store a value more than once
: check-for-redundant-ops ( cfg -- )
[
instructions>>
[
[ ##peek? ] filter [ loc>> ] map duplicates empty?
[ "Redundant peeks" throw ] unless
] [
[ ##replace? ] filter [ loc>> ] map duplicates empty?
[ "Redundant replaces" throw ] unless
] bi
] each-basic-block ;
: test-stack-analysis ( quot -- cfg )
dup cfg? [ test-cfg first ] unless
compute-predecessors
delete-useless-blocks
delete-useless-conditionals
normalize-height
stack-analysis
dup check-cfg
dup check-for-redundant-ops ;
: linearize ( cfg -- mr )
flatten-cfg instructions>> ;
local-only? off
[ ] [ [ ] test-stack-analysis drop ] unit-test
! Only peek once
[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test
! Redundant replace is redundant
[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
! Replace required here
[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
! Only one replace, at the end
[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test
! Do we support the full language?
[ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test
[ ] [ [ { [ ] [ ] } dispatch dup ] test-stack-analysis drop ] unit-test
[ ] [
[ "int" { "int" "int" } "cdecl" [ + ] alien-callback ]
test-cfg second test-stack-analysis drop
] unit-test
! Test loops
[ ] [ [ [ t ] loop ] test-stack-analysis drop ] unit-test
[ ] [ [ [ dup ] loop ] test-stack-analysis drop ] unit-test
! Make sure that peeks are inserted in the right place
[ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test
! This should be a total no-op
[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
! Don't insert inc-d/inc-r; that's wrong!
[ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test
! Bug in height tracking
[ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test
[ ] [ [ dup [ ] [ dup reverse drop ] if ] test-stack-analysis drop ] unit-test
[ ] [ [ [ drop dup 4.0 > ] find-last-integer ] test-stack-analysis drop ] unit-test
! Bugs with code that throws
[ ] [ [ [ "Oops" throw ] unless ] test-stack-analysis drop ] unit-test
[ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test
[ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test
[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test
! Make sure the replace stores a value with the right height
[ ] [
[ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize
[ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi
] unit-test
! translate-loc was the wrong way round
[ ] [
[ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize
[ [ ##load-immediate? ] count 2 assert= ]
[ [ ##peek? ] count 1 assert= ]
[ [ ##replace? ] count 3 assert= ]
tri
] unit-test
[ ] [
[ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize
[ [ ##load-immediate? ] count 2 assert= ]
[ [ ##peek? ] count 1 assert= ]
[ [ ##replace? ] count 1 assert= ]
tri
] unit-test
! Sync before a back-edge, not after
! ##peeks should be inserted before a ##loop-entry
! Don't optimize out the constants
[ 1 t ] [
[ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
[ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
] unit-test

295
basis/compiler/cfg/stack-analysis/stack-analysis.factor Normal file
View File

@ -0,0 +1,295 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel namespaces math sequences fry grouping
sets make combinators compiler.cfg.copy-prop compiler.cfg.def-use
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo
compiler.cfg.hats compiler.cfg ;
IN: compiler.cfg.stack-analysis
! Convert stack operations to register operations
! If 'poisoned' is set, disregard height information. This is set if we don't have
! height change information for an instruction.
TUPLE: state locs>vregs actual-locs>vregs changed-locs ds-height rs-height poisoned? ;
: <state> ( -- state )
state new
H{ } clone >>locs>vregs
H{ } clone >>actual-locs>vregs
H{ } clone >>changed-locs
0 >>ds-height
0 >>rs-height ;
M: state clone
call-next-method
[ clone ] change-locs>vregs
[ clone ] change-actual-locs>vregs
[ clone ] change-changed-locs ;
: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ;
: record-peek ( dst loc -- )
state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ;
: changed-loc ( loc -- )
state get changed-locs>> conjoin ;
: record-replace ( src loc -- )
dup changed-loc state get locs>vregs>> set-at ;
GENERIC: height-for ( loc -- n )
M: ds-loc height-for drop state get ds-height>> ;
M: rs-loc height-for drop state get rs-height>> ;
: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline
GENERIC: translate-loc ( loc -- loc' )
M: ds-loc translate-loc (translate-loc) - <ds-loc> ;
M: rs-loc translate-loc (translate-loc) - <rs-loc> ;
GENERIC: untranslate-loc ( loc -- loc' )
M: ds-loc untranslate-loc (translate-loc) + <ds-loc> ;
M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
: redundant-replace? ( vreg loc -- ? )
dup untranslate-loc n>> 0 <
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
: save-changed-locs ( state -- )
[ changed-locs>> ] [ locs>vregs>> ] bi '[
_ at swap 2dup redundant-replace?
[ 2drop ] [ untranslate-loc ##replace ] if
] assoc-each ;
: clear-state ( state -- )
[ locs>vregs>> clear-assoc ]
[ actual-locs>vregs>> clear-assoc ]
[ changed-locs>> clear-assoc ]
tri ;
ERROR: poisoned-state state ;
: sync-state ( -- )
state get {
[ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
[ save-changed-locs ]
[ clear-state ]
} cleave ;
: poison-state ( -- ) state get t >>poisoned? drop ;
! Abstract interpretation
GENERIC: visit ( insn -- )
! Instructions which don't have any effect on the stack
UNION: neutral-insn
##flushable
##effect ;
M: neutral-insn visit , ;
UNION: sync-if-back-edge
##branch
##conditional-branch
##compare-imm-branch
##dispatch
##loop-entry ;
SYMBOL: local-only?
t local-only? set-global
: back-edge? ( from to -- ? )
[ number>> ] bi@ > ;
: sync-state? ( -- ? )
basic-block get successors>>
[ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any?
local-only? get or ;
M: sync-if-back-edge visit
sync-state? [ sync-state ] when , ;
: adjust-d ( n -- ) state get [ + ] change-ds-height drop ;
M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ;
: adjust-r ( n -- ) state get [ + ] change-rs-height drop ;
M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ;
: eliminate-peek ( dst src -- )
! the requested stack location is already in 'src'
[ ##copy ] [ swap copies get set-at ] 2bi ;
M: ##peek visit
dup
[ dst>> ] [ loc>> translate-loc ] bi
dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ;
M: ##replace visit
[ src>> resolve ] [ loc>> translate-loc ] bi
record-replace ;
M: ##copy visit
[ call-next-method ] [ record-copy ] bi ;
M: ##call visit
[ call-next-method ] [ height>> adjust-d ] bi ;
! Instructions that poison the stack state
UNION: poison-insn
##jump
##return
##callback-return
##fixnum-mul-tail
##fixnum-add-tail
##fixnum-sub-tail ;
M: poison-insn visit call-next-method poison-state ;
! Instructions that kill all live vregs
UNION: kill-vreg-insn
poison-insn
##stack-frame
##call
##prologue
##epilogue
##fixnum-mul
##fixnum-add
##fixnum-sub
##alien-invoke
##alien-indirect ;
M: kill-vreg-insn visit sync-state , ;
: visit-alien-node ( node -- )
params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
M: ##alien-invoke visit
[ call-next-method ] [ visit-alien-node ] bi ;
M: ##alien-indirect visit
[ call-next-method ] [ visit-alien-node ] bi ;
M: ##alien-callback visit , ;
! Maps basic-blocks to states
SYMBOLS: state-in state-out ;
: initial-state ( bb states -- state ) 2drop <state> ;
: single-predecessor ( bb states -- state ) nip first clone ;
ERROR: must-equal-failed seq ;
: must-equal ( seq -- elt )
dup all-equal? [ first ] [ must-equal-failed ] if ;
: merge-heights ( state predecessors states -- state )
nip
[ [ ds-height>> ] map must-equal >>ds-height ]
[ [ rs-height>> ] map must-equal >>rs-height ] bi ;
: insert-peek ( predecessor loc -- vreg )
! XXX critical edges
'[ _ ^^peek ] add-instructions ;
: merge-loc ( predecessors locs>vregs loc -- vreg )
! Insert a ##phi in the current block where the input
! is the vreg storing loc from each predecessor block
[ '[ [ _ ] dip at ] map ] keep
'[ [ ] [ _ insert-peek ] ?if ] 2map
dup all-equal? [ first ] [ ^^phi ] if ;
: (merge-locs) ( predecessors assocs -- assoc )
dup [ keys ] map concat prune
[ [ 2nip ] [ merge-loc ] 3bi ] with with
H{ } map>assoc ;
: merge-locs ( state predecessors states -- state )
[ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
: merge-loc' ( locs>vregs loc -- vreg )
! Insert a ##phi in the current block where the input
! is the vreg storing loc from each predecessor block
'[ [ _ ] dip at ] map
dup all-equal? [ first ] [ drop f ] if ;
: merge-actual-locs ( state predecessors states -- state )
nip
[ actual-locs>vregs>> ] map
dup [ keys ] map concat prune
[ [ nip ] [ merge-loc' ] 2bi ] with
H{ } map>assoc
[ nip ] assoc-filter
>>actual-locs>vregs ;
: merge-changed-locs ( state predecessors states -- state )
nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
ERROR: cannot-merge-poisoned states ;
: multiple-predecessors ( bb states -- state )
dup [ not ] any? [
[ <state> ] 2dip
sift merge-heights
] [
dup [ poisoned?>> ] any? [
cannot-merge-poisoned
] [
[ state new ] 2dip
[ predecessors>> ] dip
{
[ merge-locs ]
[ merge-actual-locs ]
[ merge-heights ]
[ merge-changed-locs ]
} 2cleave
] if
] if ;
: merge-states ( bb states -- state )
! If any states are poisoned, save all registers
! to the stack in each branch
dup length {
{ 0 [ initial-state ] }
{ 1 [ single-predecessor ] }
[ drop multiple-predecessors ]
} case ;
: block-in-state ( bb -- states )
dup predecessors>> state-out get '[ _ at ] map merge-states ;
: set-block-in-state ( state bb -- )
[ clone ] dip state-in get set-at ;
: set-block-out-state ( state bb -- )
[ clone ] dip state-out get set-at ;
: visit-block ( bb -- )
! block-in-state may add phi nodes at the start of the basic block
! so we wrap the whole thing with a 'make'
[
dup basic-block set
dup block-in-state
[ swap set-block-in-state ] [
state [
[ instructions>> [ visit ] each ]
[ [ state get ] dip set-block-out-state ]
[ ]
tri
] with-variable
] 2bi
] V{ } make >>instructions drop ;
: stack-analysis ( cfg -- cfg' )
[
H{ } clone copies set
H{ } clone state-in set
H{ } clone state-out set
dup [ visit-block ] each-basic-block
] with-scope ;

1
basis/compiler/cfg/stack-frame/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

107
basis/compiler/cfg/stack-frame/stack-frame.factor
View File

@ -1,72 +1,55 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 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: math math.order namespaces accessors kernel layouts combinators
combinators make classes words cpu.architecture combinators.smart assocs sequences cpu.architecture ;
compiler.cfg.instructions compiler.cfg.registers ;
IN: compiler.cfg.stack-frame IN: compiler.cfg.stack-frame
SYMBOL: frame-required? TUPLE: stack-frame
{ params integer }
{ return integer }
{ total-size integer }
{ gc-root-size integer }
spill-counts ;
SYMBOL: spill-counts ! Stack frame utilities
: param-base ( -- n )
stack-frame get [ params>> ] [ return>> ] bi + ;
GENERIC: compute-stack-frame* ( insn -- ) : spill-float-offset ( n -- offset )
double-float-regs reg-size * ;
: spill-integer-base ( -- n )
stack-frame get spill-counts>> double-float-regs [ swap at ] keep reg-size *
param-base + ;
: spill-integer-offset ( n -- offset )
cells spill-integer-base + ;
: spill-area-size ( stack-frame -- n )
spill-counts>> [ swap reg-size * ] { } assoc>map sum ;
: gc-root-base ( -- n )
stack-frame get spill-area-size
param-base + ;
: gc-root-offset ( n -- n' ) gc-root-base + ;
: gc-roots-size ( live-registers live-spill-slots -- n )
[ keys [ reg-class>> reg-size ] sigma ] bi@ + ;
: (stack-frame-size) ( stack-frame -- n )
[
{
[ spill-area-size ]
[ gc-root-size>> ]
[ params>> ]
[ return>> ]
} cleave
] sum-outputs ;
: max-stack-frame ( frame1 frame2 -- frame3 ) : max-stack-frame ( frame1 frame2 -- frame3 )
[ stack-frame new ] 2dip [ stack-frame new ] 2dip
[ [ params>> ] bi@ max >>params ] [ [ params>> ] bi@ max >>params ]
[ [ return>> ] bi@ max >>return ] [ [ return>> ] bi@ max >>return ]
2bi ; [ [ gc-root-size>> ] bi@ max >>gc-root-size ]
2tri ;
M: ##stack-frame compute-stack-frame*
frame-required? on
stack-frame>> stack-frame [ max-stack-frame ] change ;
M: ##call compute-stack-frame*
word>> sub-primitive>> [ frame-required? on ] unless ;
M: _spill-counts compute-stack-frame*
counts>> stack-frame get (>>spill-counts) ;
M: insn compute-stack-frame*
class frame-required? word-prop [
frame-required? on
] when ;
\ _gc 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 -- )
frame-required? off
T{ stack-frame } clone stack-frame set
[ compute-stack-frame* ] each
stack-frame get dup stack-frame-size >>total-size drop ;
GENERIC: insert-pro/epilogues* ( insn -- )
M: ##stack-frame insert-pro/epilogues* drop ;
M: ##prologue insert-pro/epilogues*
drop frame-required? get [ stack-frame get _prologue ] when ;
M: ##epilogue insert-pro/epilogues*
drop frame-required? get [ stack-frame get _epilogue ] when ;
M: insn insert-pro/epilogues* , ;
: insert-pro/epilogues ( insns -- insns )
[ [ insert-pro/epilogues* ] each ] { } make ;
: build-stack-frame ( mr -- mr )
[
[
[ compute-stack-frame ]
[ insert-pro/epilogues ]
bi
] change-instructions
] with-scope ;

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

@ -1,40 +1,39 @@
! 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: accessors arrays kernel sequences compiler.utilities USING: accessors kernel sequences make compiler.cfg.instructions
compiler.cfg.instructions cpu.architecture ; compiler.cfg.local cpu.architecture ;
IN: compiler.cfg.two-operand IN: compiler.cfg.two-operand
! On x86, instructions take the form x = x op y ! On x86, instructions take the form x = x op y
! Our SSA IR is x = y op z ! Our SSA IR is x = y op z
! We don't bother with ##add, ##add-imm or ##sub-imm since x86 ! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm
! has a LEA instruction which is effectively a three-operand ! since x86 has LEA and IMUL instructions which are effectively
! addition ! three-operand addition and multiplication, respectively.
: make-copy ( dst src -- insn ) f \ ##copy boa ; inline : make-copy ( dst src -- insn ) \ ##copy new-insn ; inline
: make-copy/float ( dst src -- insn ) f \ ##copy-float boa ; inline : make-copy/float ( dst src -- insn ) \ ##copy-float new-insn ; inline
: convert-two-operand/integer ( insn -- insns ) : convert-two-operand/integer ( insn -- )
[ [ dst>> ] [ src1>> ] bi make-copy ] [ [ dst>> ] [ src1>> ] bi ##copy ]
[ dup dst>> >>src1 ] [ dup dst>> >>src1 , ]
bi 2array ; inline bi ; inline
: convert-two-operand/float ( insn -- insns ) : convert-two-operand/float ( insn -- )
[ [ dst>> ] [ src1>> ] bi make-copy/float ] [ [ dst>> ] [ src1>> ] bi ##copy-float ]
[ dup dst>> >>src1 ] [ dup dst>> >>src1 , ]
bi 2array ; inline bi ; inline
GENERIC: convert-two-operand* ( insn -- insns ) GENERIC: convert-two-operand* ( insn -- )
M: ##not convert-two-operand* M: ##not convert-two-operand*
[ [ dst>> ] [ src>> ] bi make-copy ] [ [ dst>> ] [ src>> ] bi ##copy ]
[ dup dst>> >>src ] [ dup dst>> >>src , ]
bi 2array ; bi ;
M: ##sub convert-two-operand* convert-two-operand/integer ; M: ##sub convert-two-operand* convert-two-operand/integer ;
M: ##mul convert-two-operand* convert-two-operand/integer ; M: ##mul convert-two-operand* convert-two-operand/integer ;
M: ##mul-imm convert-two-operand* convert-two-operand/integer ;
M: ##and convert-two-operand* convert-two-operand/integer ; M: ##and convert-two-operand* convert-two-operand/integer ;
M: ##and-imm convert-two-operand* convert-two-operand/integer ; M: ##and-imm convert-two-operand* convert-two-operand/integer ;
M: ##or convert-two-operand* convert-two-operand/integer ; M: ##or convert-two-operand* convert-two-operand/integer ;
@ -50,11 +49,11 @@ 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 ;
M: ##div-float convert-two-operand* convert-two-operand/float ; M: ##div-float convert-two-operand* convert-two-operand/float ;
M: insn convert-two-operand* ; M: insn convert-two-operand* , ;
: convert-two-operand ( mr -- mr' ) : convert-two-operand ( cfg -- cfg' )
[
two-operand? [ two-operand? [
[ convert-two-operand* ] map-flat [ drop ]
] when [ [ [ convert-two-operand* ] each ] V{ } make ]
] change-instructions ; local-optimization
] when ;

11
basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor Normal file
View File

@ -0,0 +1,11 @@
IN: compiler.cfg.useless-blocks.tests
USING: fry kernel sequences compiler.cfg.useless-blocks compiler.cfg.checker
compiler.cfg.debugger compiler.cfg.predecessors tools.test ;
{
[ [ drop 1 ] when ]
[ [ drop 1 ] unless ]
} [
[ [ ] ] dip
'[ _ test-cfg first compute-predecessors delete-useless-blocks check-cfg ] unit-test
] each

37
basis/compiler/cfg/useless-blocks/useless-blocks.factor
View File

@ -1,10 +1,12 @@
! 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: kernel accessors sequences combinators classes vectors USING: kernel accessors sequences combinators combinators.short-circuit
compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ; classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.useless-blocks IN: compiler.cfg.useless-blocks
: update-predecessor-for-delete ( bb -- ) : update-predecessor-for-delete ( bb -- )
! We have to replace occurrences of bb with bb's successor
! in bb's predecessor's list of successors.
dup predecessors>> first [ dup predecessors>> first [
[ [
2dup eq? [ drop successors>> first ] [ nip ] if 2dup eq? [ drop successors>> first ] [ nip ] if
@ -12,9 +14,13 @@ IN: compiler.cfg.useless-blocks
] change-successors drop ; ] change-successors drop ;
: update-successor-for-delete ( bb -- ) : update-successor-for-delete ( bb -- )
[ predecessors>> first ] ! We have to replace occurrences of bb with bb's predecessor
[ successors>> first predecessors>> ] ! in bb's sucessor's list of predecessors.
bi set-first ; dup successors>> first [
[
2dup eq? [ drop predecessors>> first ] [ nip ] if
] with map
] change-predecessors drop ;
: delete-basic-block ( bb -- ) : delete-basic-block ( bb -- )
[ update-predecessor-for-delete ] [ update-predecessor-for-delete ]
@ -23,17 +29,17 @@ IN: compiler.cfg.useless-blocks
: delete-basic-block? ( bb -- ? ) : delete-basic-block? ( bb -- ? )
{ {
{ [ dup instructions>> length 1 = not ] [ f ] } [ instructions>> length 1 = ]
{ [ dup predecessors>> length 1 = not ] [ f ] } [ predecessors>> length 1 = ]
{ [ dup successors>> length 1 = not ] [ f ] } [ successors>> length 1 = ]
{ [ dup instructions>> first ##branch? not ] [ f ] } [ instructions>> first ##branch? ]
[ t ] } 1&& ;
} cond nip ;
: delete-useless-blocks ( cfg -- cfg' ) : delete-useless-blocks ( cfg -- cfg' )
dup [ dup [
dup delete-basic-block? [ delete-basic-block ] [ drop ] if dup delete-basic-block? [ delete-basic-block ] [ drop ] if
] each-basic-block ; ] each-basic-block
f >>post-order ;
: delete-conditional? ( bb -- ? ) : delete-conditional? ( bb -- ? )
dup instructions>> [ drop f ] [ dup instructions>> [ drop f ] [
@ -46,10 +52,11 @@ IN: compiler.cfg.useless-blocks
: delete-conditional ( bb -- ) : delete-conditional ( bb -- )
dup successors>> first 1vector >>successors dup successors>> first 1vector >>successors
[ but-last f \ ##branch boa suffix ] change-instructions [ but-last \ ##branch new-insn suffix ] change-instructions
drop ; drop ;
: delete-useless-conditionals ( cfg -- cfg' ) : delete-useless-conditionals ( cfg -- cfg' )
dup [ dup [
dup delete-conditional? [ delete-conditional ] [ drop ] if dup delete-conditional? [ delete-conditional ] [ drop ] if
] each-basic-block ; ] each-basic-block
f >>post-order ;

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

@ -35,5 +35,8 @@ IN: compiler.cfg.utilities
: stop-iterating ( -- next ) end-basic-block f ; : stop-iterating ( -- next ) end-basic-block f ;
: call-height ( ##call -- n )
[ out-d>> length ] [ in-d>> length ] bi - ;
: emit-primitive ( node -- ) : emit-primitive ( node -- )
word>> ##call ##branch begin-basic-block ; [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;

12
basis/compiler/cfg/value-numbering/expressions/expressions.factor
View File

@ -22,17 +22,17 @@ M: constant-expr equal?
and and
] [ 2drop f ] if ; ] [ 2drop f ] if ;
SYMBOL: input-expr-counter
: next-input-expr ( -- n )
input-expr-counter [ dup 1 + ] change ;
! Expressions whose values are inputs to the basic block. We ! Expressions whose values are inputs to the basic block. We
! can eliminate a second computation having the same 'n' as ! can eliminate a second computation having the same 'n' as
! the first one; we can also eliminate input-exprs whose ! the first one; we can also eliminate input-exprs whose
! result is not used. ! result is not used.
TUPLE: input-expr < expr n ; TUPLE: input-expr < expr n ;
SYMBOL: input-expr-counter
: next-input-expr ( class -- expr )
input-expr-counter [ dup 1 + ] change input-expr boa ;
: constant>vn ( constant -- vn ) <constant> expr>vn ; inline : constant>vn ( constant -- vn ) <constant> expr>vn ; inline
GENERIC: >expr ( insn -- expr ) GENERIC: >expr ( insn -- expr )
@ -80,7 +80,7 @@ M: ##compare-imm >expr compare-imm>expr ;
M: ##compare-float >expr compare>expr ; M: ##compare-float >expr compare>expr ;
M: ##flushable >expr class next-input-expr input-expr boa ; M: ##flushable >expr class next-input-expr ;
: init-expressions ( -- ) : init-expressions ( -- )
0 input-expr-counter set ; 0 input-expr-counter set ;

34
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -13,7 +13,7 @@ GENERIC: rewrite ( insn -- insn' )
M: ##mul-imm rewrite M: ##mul-imm rewrite
dup src2>> dup power-of-2? [ dup src2>> dup power-of-2? [
[ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* f \ ##shl-imm boa [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
dup number-values dup number-values
] [ drop ] if ; ] [ drop ] if ;
@ -36,9 +36,9 @@ M: ##mul-imm rewrite
: rewrite-boolean-comparison ( expr -- insn ) : rewrite-boolean-comparison ( expr -- insn )
src1>> vreg>expr dup op>> { src1>> vreg>expr dup op>> {
{ \ ##compare [ >compare-expr< f \ ##compare-branch boa ] } { \ ##compare [ >compare-expr< \ ##compare-branch new-insn ] }
{ \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] } { \ ##compare-imm [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
{ \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] } { \ ##compare-float [ >compare-expr< \ ##compare-float-branch new-insn ] }
} case ; } case ;
: tag-fixnum-expr? ( expr -- ? ) : tag-fixnum-expr? ( expr -- ? )
@ -60,11 +60,11 @@ M: ##mul-imm rewrite
GENERIC: rewrite-tagged-comparison ( insn -- insn' ) GENERIC: rewrite-tagged-comparison ( insn -- insn' )
M: ##compare-imm-branch rewrite-tagged-comparison M: ##compare-imm-branch rewrite-tagged-comparison
(rewrite-tagged-comparison) f \ ##compare-imm-branch boa ; (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
M: ##compare-imm rewrite-tagged-comparison M: ##compare-imm rewrite-tagged-comparison
[ dst>> ] [ (rewrite-tagged-comparison) ] bi [ dst>> ] [ (rewrite-tagged-comparison) ] bi
i f \ ##compare-imm boa ; i \ ##compare-imm new-insn ;
M: ##compare-imm-branch rewrite M: ##compare-imm-branch rewrite
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
@ -79,7 +79,7 @@ M: ##compare-imm-branch rewrite
[ dst>> ] [ dst>> ]
[ src2>> ] [ src2>> ]
[ src1>> vreg>vn vn>constant ] tri [ src1>> vreg>vn vn>constant ] tri
cc= f i \ ##compare-imm boa ; cc= i \ ##compare-imm new-insn ;
M: ##compare rewrite M: ##compare rewrite
dup flip-comparison? [ dup flip-comparison? [
@ -96,9 +96,9 @@ M: ##compare rewrite
: rewrite-redundant-comparison ( insn -- insn' ) : rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri { [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
{ \ ##compare [ >compare-expr< i f \ ##compare boa ] } { \ ##compare [ >compare-expr< i \ ##compare new-insn ] }
{ \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] } { \ ##compare-imm [ >compare-imm-expr< i \ ##compare-imm new-insn ] }
{ \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] } { \ ##compare-float [ >compare-expr< i \ ##compare-float new-insn ] }
} case } case
swap cc= eq? [ [ negate-cc ] change-cc ] when ; swap cc= eq? [ [ negate-cc ] change-cc ] when ;
@ -114,18 +114,4 @@ M: ##compare-imm rewrite
] when ] when
] when ; ] when ;
: dispatch-offset ( expr -- n )
[ in2>> vn>constant tag-bits get neg shift ] [ op>> ] bi
\ ##sub-imm eq? [ neg ] when ;
: add-dispatch-offset? ( insn -- expr ? )
src>> vreg>expr dup op>> { ##add-imm ##sub-imm } memq? ; inline
M: ##dispatch rewrite
dup add-dispatch-offset? [
[ clone ] dip
[ in1>> vn>vreg >>src ]
[ dispatch-offset '[ _ + ] change-offset ] bi
] [ drop ] if ;
M: insn rewrite ; M: insn rewrite ;

39
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -2,7 +2,7 @@ IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions USING: compiler.cfg.value-numbering compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger cpu.architecture compiler.cfg.registers compiler.cfg.debugger cpu.architecture
tools.test kernel math combinators.short-circuit accessors tools.test kernel math combinators.short-circuit accessors
sequences ; sequences compiler.cfg vectors arrays ;
: trim-temps ( insns -- insns ) : trim-temps ( insns -- insns )
[ [
@ -13,6 +13,10 @@ sequences ;
} 1|| [ f >>temp ] when } 1|| [ f >>temp ] when
] map ; ] map ;
: test-value-numbering ( insns -- insns )
{ } init-value-numbering
value-numbering-step ;
[ [
{ {
T{ ##peek f V int-regs 45 D 1 } T{ ##peek f V int-regs 45 D 1 }
@ -24,7 +28,7 @@ sequences ;
T{ ##peek f V int-regs 45 D 1 } T{ ##peek f V int-regs 45 D 1 }
T{ ##copy f V int-regs 48 V int-regs 45 } T{ ##copy f V int-regs 48 V int-regs 45 }
T{ ##compare-imm-branch f V int-regs 48 7 cc/= } T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
} value-numbering } test-value-numbering
] unit-test ] unit-test
[ [
@ -40,14 +44,14 @@ sequences ;
T{ ##peek f V int-regs 3 D 0 } T{ ##peek f V int-regs 3 D 0 }
T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 } T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
T{ ##replace f V int-regs 4 D 0 } T{ ##replace f V int-regs 4 D 0 }
} value-numbering } test-value-numbering
] unit-test ] unit-test
[ t ] [ [ t ] [
{ {
T{ ##peek f V int-regs 1 D 0 } T{ ##peek f V int-regs 1 D 0 }
T{ ##dispatch f V int-regs 1 V int-regs 2 0 } T{ ##dispatch f V int-regs 1 V int-regs 2 }
} dup value-numbering = } dup test-value-numbering =
] unit-test ] unit-test
[ t ] [ [ t ] [
@ -60,7 +64,7 @@ sequences ;
T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 } T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 }
T{ ##shl-imm f V int-regs 23 V int-regs 22 3 } T{ ##shl-imm f V int-regs 23 V int-regs 22 3 }
T{ ##replace f V int-regs 23 D 0 } T{ ##replace f V int-regs 23 D 0 }
} dup value-numbering = } dup test-value-numbering =
] unit-test ] unit-test
[ [
@ -76,7 +80,7 @@ sequences ;
T{ ##mul-imm f V int-regs 2 V int-regs 1 8 } T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
T{ ##shr-imm f V int-regs 3 V int-regs 2 3 } T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
T{ ##replace f V int-regs 3 D 0 } T{ ##replace f V int-regs 3 D 0 }
} value-numbering } test-value-numbering
] unit-test ] unit-test
[ [
@ -94,7 +98,7 @@ sequences ;
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= } T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
T{ ##replace f V int-regs 6 D 0 } T{ ##replace f V int-regs 6 D 0 }
} value-numbering trim-temps } test-value-numbering trim-temps
] unit-test ] unit-test
[ [
@ -112,7 +116,7 @@ sequences ;
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= } T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
T{ ##replace f V int-regs 6 D 0 } T{ ##replace f V int-regs 6 D 0 }
} value-numbering trim-temps } test-value-numbering trim-temps
] unit-test ] unit-test
[ [
@ -134,7 +138,7 @@ sequences ;
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= } T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
T{ ##replace f V int-regs 14 D 0 } T{ ##replace f V int-regs 14 D 0 }
} value-numbering trim-temps } test-value-numbering trim-temps
] unit-test ] unit-test
[ [
@ -150,5 +154,18 @@ sequences ;
T{ ##peek f V int-regs 30 D -2 } T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
T{ ##compare-imm-branch f V int-regs 33 5 cc/= } T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
} value-numbering trim-temps } test-value-numbering trim-temps
] unit-test
[
{
T{ ##copy f V int-regs 48 V int-regs 45 }
T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
}
] [
{ V int-regs 45 } init-value-numbering
{
T{ ##copy f V int-regs 48 V int-regs 45 }
T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
} value-numbering-step
] unit-test ] unit-test

13
basis/compiler/cfg/value-numbering/value-numbering.factor
View File

@ -2,6 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs biassocs classes kernel math accessors USING: namespaces assocs biassocs classes kernel math accessors
sorting sets sequences sorting sets sequences
compiler.cfg.local
compiler.cfg.liveness
compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions compiler.cfg.value-numbering.expressions
compiler.cfg.value-numbering.propagate compiler.cfg.value-numbering.propagate
@ -9,7 +11,16 @@ compiler.cfg.value-numbering.simplify
compiler.cfg.value-numbering.rewrite ; compiler.cfg.value-numbering.rewrite ;
IN: compiler.cfg.value-numbering IN: compiler.cfg.value-numbering
: value-numbering ( insns -- insns' ) : number-input-values ( live-in -- )
[ [ f next-input-expr simplify ] dip set-vn ] each ;
: init-value-numbering ( live-in -- )
init-value-graph init-value-graph
init-expressions init-expressions
number-input-values ;
: value-numbering-step ( insns -- insns' )
[ [ number-values ] [ rewrite propagate ] bi ] map ; [ [ number-values ] [ rewrite propagate ] bi ] map ;
: value-numbering ( cfg -- cfg' )
[ init-value-numbering ] [ value-numbering-step ] local-optimization ;

11
basis/compiler/cfg/write-barrier/write-barrier-tests.factor
View File

@ -1,8 +1,11 @@
USING: compiler.cfg.write-barrier compiler.cfg.instructions USING: compiler.cfg.write-barrier compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger cpu.architecture compiler.cfg.registers compiler.cfg.debugger cpu.architecture
arrays tools.test ; arrays tools.test vectors compiler.cfg kernel accessors ;
IN: compiler.cfg.write-barrier.tests IN: compiler.cfg.write-barrier.tests
: test-write-barrier ( insns -- insns )
write-barriers-step ;
[ [
{ {
T{ ##peek f V int-regs 4 D 0 f } T{ ##peek f V int-regs 4 D 0 f }
@ -24,7 +27,7 @@ IN: compiler.cfg.write-barrier.tests
T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 } T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 }
T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 } T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
T{ ##replace f V int-regs 7 D 0 } T{ ##replace f V int-regs 7 D 0 }
} eliminate-write-barriers } test-write-barrier
] unit-test ] unit-test
[ [
@ -42,7 +45,7 @@ IN: compiler.cfg.write-barrier.tests
T{ ##peek f V int-regs 6 D -2 } T{ ##peek f V int-regs 6 D -2 }
T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 } T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 } T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
} eliminate-write-barriers } test-write-barrier
] unit-test ] unit-test
[ [
@ -69,5 +72,5 @@ IN: compiler.cfg.write-barrier.tests
T{ ##copy f V int-regs 29 V int-regs 19 } T{ ##copy f V int-regs 29 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 } T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 } T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
} eliminate-write-barriers } test-write-barrier
] unit-test ] unit-test

10
basis/compiler/cfg/write-barrier/write-barrier.factor
View File

@ -1,7 +1,8 @@
! 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: kernel accessors namespaces assocs sets sequences locals USING: kernel accessors namespaces assocs sets sequences locals
compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop ; compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop
compiler.cfg.liveness compiler.cfg.local ;
IN: compiler.cfg.write-barrier IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits. ! Eliminate redundant write barrier hits.
@ -35,8 +36,11 @@ M: ##set-slot-imm eliminate-write-barrier
M: insn eliminate-write-barrier ; M: insn eliminate-write-barrier ;
: eliminate-write-barriers ( insns -- insns' ) : write-barriers-step ( insns -- insns' )
H{ } clone safe set H{ } clone safe set
H{ } clone mutated set H{ } clone mutated set
H{ } clone copies set H{ } clone copies set
[ eliminate-write-barrier ] map sift ; [ eliminate-write-barrier ] map sift ;
: eliminate-write-barriers ( cfg -- cfg' )
[ drop ] [ write-barriers-step ] local-optimization ;

14
basis/compiler/codegen/codegen-tests.factor Normal file
View File

@ -0,0 +1,14 @@
IN: compiler.codegen.tests
USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
compiler.constants ;
[ ] [ [ ] with-fixup drop ] unit-test
[ ] [ [ \ + %call ] with-fixup drop ] unit-test
[ ] [ [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
[ ] [ [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
! Error checking
[ [ <label> dup define-label %jump-label ] with-fixup ] must-fail
[ [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
[ [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail

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

@ -8,8 +8,10 @@ continuations.private fry cpu.architecture
source-files.errors source-files.errors
compiler.errors compiler.errors
compiler.alien compiler.alien
compiler.constants
compiler.cfg compiler.cfg
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.stack-frame
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.builder compiler.cfg.builder
compiler.codegen.fixup compiler.codegen.fixup
@ -26,14 +28,6 @@ SYMBOL: registers
: ?register ( obj -- operand ) : ?register ( obj -- operand )
dup vreg? [ register ] when ; dup vreg? [ register ] when ;
: generate-insns ( insns -- code )
[
[
dup regs>> registers set
generate-insn
] each
] { } make fixup ;
TUPLE: asm label code calls ; TUPLE: asm label code calls ;
SYMBOL: calls SYMBOL: calls
@ -51,17 +45,22 @@ SYMBOL: labels
: init-generator ( word -- ) : init-generator ( word -- )
H{ } clone labels set H{ } clone labels set
V{ } clone literal-table set
V{ } clone calls set V{ } clone calls set
compiling-word set compiling-word set
compiled-stack-traces? [ compiling-word get add-literal ] when ; compiled-stack-traces? [ compiling-word get add-literal ] when ;
: generate-insns ( asm -- code )
[
[ word>> init-generator ]
[
instructions>>
[ [ regs>> registers set ] [ generate-insn ] bi ] each
] bi
] with-fixup ;
: generate ( mr -- asm ) : generate ( mr -- asm )
[ [
[ label>> ] [ label>> ] [ generate-insns ] bi calls get
[ word>> init-generator ]
[ instructions>> generate-insns ] tri
calls get
asm boa asm boa
] with-scope ; ] with-scope ;
@ -92,10 +91,13 @@ M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
M: ##return generate-insn drop %return ; M: ##return generate-insn drop %return ;
M: ##dispatch-label generate-insn label>> %dispatch-label ; M: _dispatch generate-insn
[ src>> register ] [ temp>> register ] bi %dispatch ;
M: ##dispatch generate-insn M: _dispatch-label generate-insn
[ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ; label>> lookup-label
cell 0 <repetition> %
rc-absolute-cell label-fixup ;
: >slot< ( insn -- dst obj slot tag ) : >slot< ( insn -- dst obj slot tag )
{ {
@ -236,7 +238,13 @@ M: ##write-barrier generate-insn
[ table>> register ] [ table>> register ]
tri %write-barrier ; tri %write-barrier ;
M: _gc generate-insn drop %gc ; M: _gc generate-insn
{
[ temp1>> register ]
[ temp2>> register ]
[ gc-roots>> ]
[ gc-root-count>> ]
} cleave %gc ;
M: ##loop-entry generate-insn drop %loop-entry ; M: ##loop-entry generate-insn drop %loop-entry ;
@ -245,16 +253,6 @@ M: ##alien-global generate-insn
%alien-global ; %alien-global ;
! ##alien-invoke ! ##alien-invoke
GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
M: single-float-regs reg-size drop 4 ;
M: double-float-regs reg-size drop 8 ;
M: stack-params reg-size drop "void*" heap-size ;
GENERIC: reg-class-variable ( register-class -- symbol ) GENERIC: reg-class-variable ( register-class -- symbol )
M: reg-class reg-class-variable ; M: reg-class reg-class-variable ;
@ -486,7 +484,7 @@ M: _epilogue generate-insn
stack-frame>> total-size>> %epilogue ; stack-frame>> total-size>> %epilogue ;
M: _label generate-insn M: _label generate-insn
id>> lookup-label , ; id>> lookup-label resolve-label ;
M: _branch generate-insn M: _branch generate-insn
label>> lookup-label %jump-label ; label>> lookup-label %jump-label ;
@ -533,4 +531,10 @@ M: _reload generate-insn
{ double-float-regs [ %reload-float ] } { double-float-regs [ %reload-float ] }
} case ; } case ;
M: _copy generate-insn
[ dst>> ] [ src>> ] [ class>> ] tri {
{ int-regs [ %copy ] }
{ double-float-regs [ %copy-float ] }
} case ;
M: _spill-counts generate-insn drop ; M: _spill-counts generate-insn drop ;

98
basis/compiler/codegen/fixup/fixup.factor
View File

@ -4,48 +4,48 @@ USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts words quotations strings alien.accessors alien.strings layouts
system combinators math.bitwise math.order system combinators math.bitwise math.order
accessors growable cpu.architecture compiler.constants ; accessors growable compiler.constants ;
IN: compiler.codegen.fixup IN: compiler.codegen.fixup
GENERIC: fixup* ( obj -- ) ! Literal table
SYMBOL: literal-table
: add-literal ( obj -- ) literal-table get push ;
! Labels
SYMBOL: label-table
TUPLE: label offset ;
: <label> ( -- label ) label new ;
: define-label ( name -- ) <label> swap set ;
: compiled-offset ( -- n ) building get length ; : compiled-offset ( -- n ) building get length ;
: resolve-label ( label/name -- )
dup label? [ get ] unless
compiled-offset >>offset drop ;
: offset-for-class ( class -- n )
rc-absolute-cell = cell 4 ? compiled-offset swap - ;
TUPLE: label-fixup { label label } { class integer } { offset integer } ;
: label-fixup ( label class -- )
dup offset-for-class \ label-fixup boa label-table get push ;
! Relocation table
SYMBOL: relocation-table SYMBOL: relocation-table
SYMBOL: label-table
M: label fixup* compiled-offset >>offset drop ;
TUPLE: label-fixup label class ;
: label-fixup ( label class -- ) \ label-fixup boa , ;
M: label-fixup fixup*
dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when
[ class>> ] [ label>> ] bi compiled-offset 4 - swap
3array label-table get push ;
TUPLE: rel-fixup class type ;
: rel-fixup ( class type -- ) \ rel-fixup boa , ;
: push-4 ( value vector -- ) : push-4 ( value vector -- )
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ; swap set-alien-unsigned-4 ;
M: rel-fixup fixup* : add-relocation-entry ( type class offset -- )
[ type>> ] { 0 24 28 } bitfield relocation-table get push-4 ;
[ class>> ]
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] tri
{ 0 24 28 } bitfield
relocation-table get push-4 ;
M: integer fixup* , ; : rel-fixup ( class type -- )
swap dup offset-for-class add-relocation-entry ;
SYMBOL: literal-table
: add-literal ( obj -- ) literal-table get push ;
: add-dlsym-literals ( symbol dll -- ) : add-dlsym-literals ( symbol dll -- )
[ string>symbol add-literal ] [ add-literal ] bi* ; [ string>symbol add-literal ] [ add-literal ] bi* ;
@ -74,22 +74,34 @@ SYMBOL: literal-table
: rel-here ( offset class -- ) : rel-here ( offset class -- )
[ add-literal ] dip rt-here rel-fixup ; [ add-literal ] dip rt-here rel-fixup ;
! And the rest
: resolve-offset ( label-fixup -- offset )
label>> offset>> [ "Unresolved label" throw ] unless* ;
: resolve-absolute-label ( label-fixup -- )
dup resolve-offset neg add-literal
[ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
: resolve-relative-label ( label-fixup -- label )
[ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
: resolve-labels ( label-fixups -- labels' )
[ class>> rc-absolute? ] partition
[ [ resolve-absolute-label ] each ]
[ [ resolve-relative-label ] map concat ]
bi* ;
: init-fixup ( -- ) : init-fixup ( -- )
BV{ } clone relocation-table set V{ } clone literal-table set
V{ } clone label-table set ; V{ } clone label-table set
BV{ } clone relocation-table set ;
: resolve-labels ( labels -- labels' ) : with-fixup ( quot -- code )
[
first3 offset>>
[ "Unresolved label" throw ] unless*
3array
] map concat ;
: fixup ( fixup-directives -- code )
[ [
init-fixup init-fixup
[ fixup* ] each call
label-table [ resolve-labels ] change
literal-table get >array literal-table get >array
relocation-table get >byte-array relocation-table get >byte-array
label-table get resolve-labels label-table get
] B{ } make 4array ; ] B{ } make 4array ; inline

43
basis/compiler/compiler.factor
View File

@ -3,13 +3,20 @@
USING: accessors kernel namespaces arrays sequences io words fry USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic continuations vocabs assocs dlists definitions math graphs generic
generic.single combinators deques search-deques macros generic.single combinators deques search-deques macros
source-files.errors stack-checker stack-checker.state source-files.errors combinators.short-circuit
stack-checker.inlining stack-checker.errors combinators.short-circuit
compiler.errors compiler.units compiler.tree.builder stack-checker stack-checker.state stack-checker.inlining stack-checker.errors
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
compiler.cfg.linearization compiler.cfg.two-operand compiler.errors compiler.units compiler.utilities
compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
compiler.utilities ; compiler.tree.builder
compiler.tree.optimizer
compiler.cfg.builder
compiler.cfg.optimizer
compiler.cfg.mr
compiler.codegen ;
IN: compiler IN: compiler
SYMBOL: compile-queue SYMBOL: compile-queue
@ -89,11 +96,11 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
: not-compiled-def ( word error -- def ) : not-compiled-def ( word error -- def )
'[ _ _ not-compiled ] [ ] like ; '[ _ _ not-compiled ] [ ] like ;
: deoptimize* ( word -- * )
dup def>> deoptimize-with ;
: ignore-error ( word error -- * ) : ignore-error ( word error -- * )
drop drop [ clear-compiler-error ] [ deoptimize* ] bi ;
[ clear-compiler-error ]
[ dup def>> deoptimize-with ]
bi ;
: remember-error ( word error -- * ) : remember-error ( word error -- * )
[ swap <compiler-error> compiler-error ] [ swap <compiler-error> compiler-error ]
@ -117,13 +124,13 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
: contains-breakpoints? ( -- ? ) : contains-breakpoints? ( -- ? )
dependencies get keys [ "break?" word-prop ] any? ; dependencies get keys [ "break?" word-prop ] any? ;
: frontend ( word -- nodes ) : frontend ( word -- tree )
#! If the word contains breakpoints, don't optimize it, since #! If the word contains breakpoints, don't optimize it, since
#! the walker does not support this. #! the walker does not support this.
dup optimize? [ dup optimize? [
[ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep [ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if contains-breakpoints? [ nip deoptimize* ] [ drop ] if
] [ dup def>> deoptimize-with ] if ; ] [ deoptimize* ] if ;
: compile-dependency ( word -- ) : compile-dependency ( word -- )
#! If a word calls an unoptimized word, try to compile the callee. #! If a word calls an unoptimized word, try to compile the callee.
@ -143,13 +150,10 @@ t compile-dependencies? set-global
[ compile-dependencies ] [ compile-dependencies ]
bi ; bi ;
: backend ( nodes word -- ) : backend ( tree word -- )
build-cfg [ build-cfg [
optimize-cfg optimize-cfg
build-mr build-mr
convert-two-operand
linear-scan
build-stack-frame
generate generate
save-asm save-asm
] each ; ] each ;
@ -189,7 +193,8 @@ M: optimizing-compiler recompile ( words -- alist )
] each ] each
compile-queue get compile-loop compile-queue get compile-loop
compiled get >alist compiled get >alist
] with-scope ; ] with-scope
"trace-compilation" get [ "--- compile done" print flush ] when ;
: with-optimizer ( quot -- ) : with-optimizer ( quot -- )
[ optimizing-compiler compiler-impl ] dip with-variable ; inline [ optimizing-compiler compiler-impl ] dip with-variable ; inline

31
basis/compiler/tests/codegen.factor
View File

@ -2,7 +2,7 @@ USING: generalizations accessors arrays compiler kernel kernel.private
math hashtables.private math.private namespaces sequences tools.test math hashtables.private math.private namespaces sequences tools.test
namespaces.private slots.private sequences.private byte-arrays alien namespaces.private slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make ; combinators vectors grouping make alien.c-types ;
QUALIFIED: namespaces.private QUALIFIED: namespaces.private
IN: compiler.tests.codegen IN: compiler.tests.codegen
@ -282,3 +282,32 @@ TUPLE: cucumber ;
M: cucumber equal? "The cucumber has no equal" throw ; M: cucumber equal? "The cucumber has no equal" throw ;
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test [ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
[ 4294967295 B{ 255 255 255 255 } -1 ]
[
-1 <int> -1 <int>
[ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ]
compile-call
] unit-test
! Regression found while working on global register allocation
: linear-scan-regression-1 ( a b c -- ) 3array , ;
: linear-scan-regression-2 ( a b -- ) 2array , ;
: linear-scan-regression ( a b c -- )
[ linear-scan-regression-2 ]
[ linear-scan-regression-1 ]
bi-curry bi-curry interleave ;
[
{
{ 1 "x" "y" }
{ "x" "y" }
{ 2 "x" "y" }
{ "x" "y" }
{ 3 "x" "y" }
}
] [
[ { 1 2 3 } "x" "y" linear-scan-regression ] { } make
] unit-test

7
basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

@ -328,3 +328,10 @@ C: <ro-box> ro-box
TUPLE: empty-tuple ; TUPLE: empty-tuple ;
[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test [ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
! Make sure that initial-quot: doesn't inhibit unboxing
TUPLE: initial-quot-tuple { x read-only initial-quot: [ 0 ] } ;
[ 1 ] [
[ initial-quot-tuple new x>> ] count-unboxed-allocations
] unit-test

4
basis/compiler/tree/optimizer/optimizer.factor
View File

@ -25,6 +25,7 @@ SYMBOL: check-optimizer?
] when ; ] when ;
: optimize-tree ( nodes -- nodes' ) : optimize-tree ( nodes -- nodes' )
[
analyze-recursive analyze-recursive
normalize normalize
propagate propagate
@ -39,4 +40,5 @@ SYMBOL: check-optimizer?
?check ?check
compute-def-use compute-def-use
optimize-modular-arithmetic optimize-modular-arithmetic
finalize ; finalize
] with-scope ;

7
basis/compression/huffman/huffman.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Marc Fauconneau. ! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs constructors fry USING: accessors arrays assocs fry
hashtables io kernel locals math math.order math.parser hashtables io kernel locals math math.order math.parser
math.ranges multiline sequences ; math.ranges multiline sequences ;
IN: compression.huffman IN: compression.huffman
@ -58,7 +58,10 @@ TUPLE: huffman-decoder
{ rtable } { rtable }
{ bits/level } ; { bits/level } ;
CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder ) : <huffman-decoder> ( bs tdesc -- decoder )
huffman-decoder new
swap >>tdesc
swap >>bs
16 >>bits/level 16 >>bits/level
[ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ; [ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;

22
basis/compression/inflate/inflate.factor Executable file → Normal file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Marc Fauconneau. ! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays USING: accessors arrays assocs byte-arrays
byte-vectors combinators constructors fry grouping hashtables byte-vectors combinators fry grouping hashtables
compression.huffman images io.binary kernel locals compression.huffman images io.binary kernel locals
math math.bitwise math.order math.ranges multiline sequences math math.bitwise math.order math.ranges multiline sequences
sorting ; sorting ;
@ -151,7 +151,16 @@ CONSTANT: dist-table
] when ] when
] map ; ] map ;
: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ; :: inflate-raw ( bitstream -- bytes )
8 bitstream bs:align
16 bitstream bs:read :> len
16 bitstream bs:read :> nlen
len nlen + 16 >signed -1 assert= ! len + ~len = -1
bitstream byte-pos>>
bitstream byte-pos>> len +
bitstream bytes>> <slice>
len 8 * bitstream bs:seek ;
: inflate-static ( bitstream -- bytes ) zlib-unimplemented ; : inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
:: inflate-loop ( bitstream -- bytes ) :: inflate-loop ( bitstream -- bytes )
@ -194,17 +203,16 @@ CONSTANT: dist-table
PRIVATE> PRIVATE>
! for debug -- shows residual values : reverse-png-filter' ( lines -- byte-array )
: reverse-png-filter' ( lines -- filtered )
[ first ] [ 1 tail ] [ map ] bi-curry@ bi nip [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
concat [ 128 + 256 wrap ] map ; concat [ 128 + ] B{ } map-as ;
: reverse-png-filter ( lines -- filtered ) : reverse-png-filter ( lines -- byte-array )
dup first [ 0 ] replicate prefix dup first [ 0 ] replicate prefix
[ { 0 0 } prepend ] map [ { 0 0 } prepend ] map
2 clump [ 2 clump [
first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
] map concat ; ] map B{ } concat-as ;
: zlib-inflate ( bytes -- bytes ) : zlib-inflate ( bytes -- bytes )
bs:<lsb0-bit-reader> bs:<lsb0-bit-reader>

1
basis/compression/run-length/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

75
basis/compression/run-length/run-length.factor Normal file
View File

@ -0,0 +1,75 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators grouping kernel locals math
math.matrices math.order multiline sequence-parser sequences
tools.continuations ;
IN: compression.run-length
: run-length-uncompress ( byte-array -- byte-array' )
2 group [ first2 <array> ] map B{ } concat-as ;
: 8hi-lo ( byte -- hi lo )
[ HEX: f0 bitand -4 shift ] [ HEX: f bitand ] bi ; inline
:: run-length-uncompress-bitmap4 ( byte-array m n -- byte-array' )
byte-array <sequence-parser> :> sp
m 1 + n zero-matrix :> matrix
n 4 mod n + :> stride
0 :> i!
0 :> j!
f :> done?!
[
! i j [ number>string ] bi@ " " glue .
sp next dup 0 = [
sp next dup HEX: 03 HEX: ff between? [
nip [ sp ] dip dup odd?
[ 1 + take-n but-last ] [ take-n ] if
[ j matrix i swap nth copy ] [ length j + j! ] bi
] [
nip {
{ 0 [ i 1 + i! 0 j! ] }
{ 1 [ t done?! ] }
{ 2 [ sp next j + j! sp next i + i! ] }
} case
] if
] [
[ sp next 8hi-lo 2array <repetition> concat ] [ head ] bi
[ j matrix i swap nth copy ] [ length j + j! ] bi
] if
! j stride >= [ i 1 + i! 0 j! ] when
j stride >= [ 0 j! ] when
done? not
] loop
matrix B{ } concat-as ;
:: run-length-uncompress-bitmap8 ( byte-array m n -- byte-array' )
byte-array <sequence-parser> :> sp
m 1 + n zero-matrix :> matrix
n 4 mod n + :> stride
0 :> i!
0 :> j!
f :> done?!
[
! i j [ number>string ] bi@ " " glue .
sp next dup 0 = [
sp next dup HEX: 03 HEX: ff between? [
nip [ sp ] dip dup odd?
[ 1 + take-n but-last ] [ take-n ] if
[ j matrix i swap nth copy ] [ length j + j! ] bi
] [
nip {
{ 0 [ i 1 + i! 0 j! ] }
{ 1 [ t done?! ] }
{ 2 [ sp next j + j! sp next i + i! ] }
} case
] if
] [
sp next <array> [ j matrix i swap nth copy ] [ length j + j! ] bi
] if
! j stride >= [ i 1 + i! 0 j! ] when
j stride >= [ 0 j! ] when
done? not
] loop
matrix B{ } concat-as ;

3
basis/concurrency/distributed/distributed.factor
View File

@ -13,9 +13,8 @@ SYMBOL: local-node
[ first2 get-process send ] [ stop-this-server ] if* ; [ first2 get-process send ] [ stop-this-server ] if* ;
: <node-server> ( addrspec -- threaded-server ) : <node-server> ( addrspec -- threaded-server )
<threaded-server> binary <threaded-server>
swap >>insecure swap >>insecure
binary >>encoding
"concurrency.distributed" >>name "concurrency.distributed" >>name
[ handle-node-client ] >>handler ; [ handle-node-client ] >>handler ;

21
basis/constructors/constructors-tests.factor
View File

@ -1,21 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test constructors calendar kernel accessors
combinators.short-circuit ;
IN: constructors.tests
TUPLE: stock-spread stock spread timestamp ;
CONSTRUCTOR: stock-spread ( stock spread -- stock-spread )
now >>timestamp ;
SYMBOL: AAPL
[ t ] [
AAPL 1234 <stock-spread>
{
[ stock>> AAPL eq? ]
[ spread>> 1234 = ]
[ timestamp>> timestamp? ]
} 1&&
] unit-test

23
basis/constructors/constructors.factor
View File

@ -1,23 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: slots kernel sequences fry accessors parser lexer words
effects.parser macros ;
IN: constructors
! An experiment
MACRO: set-slots ( slots -- quot )
<reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
: construct ( ... class slots -- instance )
[ new ] dip set-slots ; inline
: define-constructor ( name class effect body -- )
[ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
define-declared ;
SYNTAX: CONSTRUCTOR:
scan-word [ name>> "<" ">" surround create-in ] keep
complete-effect
parse-definition
define-constructor ;

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

@ -5,13 +5,6 @@ memory namespaces make sequences layouts system hashtables
classes alien byte-arrays combinators words sets fry ; classes alien byte-arrays combinators words sets fry ;
IN: cpu.architecture IN: cpu.architecture
! Labels
TUPLE: label offset ;
: <label> ( -- label ) label new ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
! Register classes ! Register classes
SINGLETON: int-regs SINGLETON: int-regs
SINGLETON: single-float-regs SINGLETON: single-float-regs
@ -19,12 +12,22 @@ SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-float-regs ; UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ; UNION: reg-class int-regs float-regs ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
! A pseudo-register class for parameters spilled on the stack ! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params SINGLETON: stack-params
GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
M: single-float-regs reg-size drop 4 ;
M: double-float-regs reg-size drop 8 ;
M: stack-params reg-size drop cell ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
! Return values of this class go here ! Return values of this class go here
GENERIC: return-reg ( register-class -- reg ) GENERIC: return-reg ( register-class -- reg )
@ -51,8 +54,7 @@ HOOK: %jump cpu ( word -- )
HOOK: %jump-label cpu ( label -- ) HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- ) HOOK: %return cpu ( -- )
HOOK: %dispatch cpu ( src temp offset -- ) HOOK: %dispatch cpu ( src temp -- )
HOOK: %dispatch-label cpu ( word -- )
HOOK: %slot cpu ( dst obj slot tag temp -- ) HOOK: %slot cpu ( dst obj slot tag temp -- )
HOOK: %slot-imm cpu ( dst obj slot tag -- ) HOOK: %slot-imm cpu ( dst obj slot tag -- )
@ -126,7 +128,7 @@ HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %allot cpu ( dst size class temp -- ) HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src card# table -- ) HOOK: %write-barrier cpu ( src card# table -- )
HOOK: %gc cpu ( -- ) HOOK: %gc cpu ( temp1 temp2 live-registers live-spill-slots -- )
HOOK: %prologue cpu ( n -- ) HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- ) HOOK: %epilogue cpu ( n -- )

28
basis/cpu/ppc/ppc.factor
View File

@ -3,10 +3,11 @@
USING: accessors assocs sequences kernel combinators make math USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words math.order math.ranges system namespaces locals layouts words
alien alien.accessors alien.c-types literals cpu.architecture alien alien.accessors alien.c-types literals cpu.architecture
cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers
compiler.cfg.instructions compiler.constants compiler.codegen compiler.cfg.instructions compiler.constants compiler.codegen
compiler.codegen.fixup compiler.cfg.intrinsics compiler.codegen.fixup compiler.cfg.intrinsics
compiler.cfg.stack-frame compiler.units ; compiler.cfg.stack-frame compiler.cfg.build-stack-frame
compiler.units ;
FROM: cpu.ppc.assembler => B ; FROM: cpu.ppc.assembler => B ;
IN: cpu.ppc IN: cpu.ppc
@ -124,16 +125,13 @@ M: ppc %jump ( word -- )
M: ppc %jump-label ( label -- ) B ; M: ppc %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ; M: ppc %return ( -- ) BLR ;
M:: ppc %dispatch ( src temp offset -- ) M:: ppc %dispatch ( src temp -- )
0 temp LOAD32 0 temp LOAD32
4 offset + cells rc-absolute-ppc-2/2 rel-here 4 cells rc-absolute-ppc-2/2 rel-here
temp temp src LWZX temp temp src LWZX
temp MTCTR temp MTCTR
BCTR ; BCTR ;
M: ppc %dispatch-label ( word -- )
B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
:: (%slot) ( obj slot tag temp -- reg offset ) :: (%slot) ( obj slot tag temp -- reg offset )
temp slot obj ADD temp slot obj ADD
temp tag neg ; inline temp tag neg ; inline
@ -464,16 +462,18 @@ M:: ppc %write-barrier ( src card# table -- )
src card# deck-bits SRWI src card# deck-bits SRWI
table scratch-reg card# STBX ; table scratch-reg card# STBX ;
M: ppc %gc M:: ppc %gc ( temp1 temp2 gc-roots gc-root-count -- )
"end" define-label "end" define-label
12 load-zone-ptr temp2 load-zone-ptr
11 12 cell LWZ ! nursery.here -> r11 temp1 temp2 cell LWZ
12 12 3 cells LWZ ! nursery.end -> r12 temp2 temp2 3 cells LWZ
11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here temp1 temp1 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
11 0 12 CMP ! is here >= end? temp1 0 temp2 CMP ! is here >= end?
"end" get BLE "end" get BLE
%prepare-alien-invoke %prepare-alien-invoke
"minor_gc" f %alien-invoke 0 3 LI
0 4 LI
"inline_gc" f %alien-invoke
"end" resolve-label ; "end" resolve-label ;
M: ppc %prologue ( n -- ) M: ppc %prologue ( n -- )

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

@ -3,10 +3,11 @@
USING: locals alien.c-types alien.syntax arrays kernel USING: locals alien.c-types alien.syntax arrays kernel
math namespaces sequences system layouts io vocabs.loader math namespaces sequences system layouts io vocabs.loader
accessors init combinators command-line cpu.x86.assembler accessors init combinators command-line cpu.x86.assembler
cpu.x86 cpu.architecture compiler compiler.units cpu.x86 cpu.architecture make compiler compiler.units
compiler.constants compiler.alien compiler.codegen compiler.constants compiler.alien compiler.codegen
compiler.codegen.fixup compiler.cfg.instructions compiler.codegen.fixup compiler.cfg.instructions
compiler.cfg.builder compiler.cfg.intrinsics make ; compiler.cfg.builder compiler.cfg.intrinsics
compiler.cfg.stack-frame ;
IN: cpu.x86.32 IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once. ! We implement the FFI for Linux, OS X and Windows all at once.
@ -26,10 +27,10 @@ M: x86.32 stack-reg ESP ;
M: x86.32 temp-reg-1 ECX ; M: x86.32 temp-reg-1 ECX ;
M: x86.32 temp-reg-2 EDX ; M: x86.32 temp-reg-2 EDX ;
M:: x86.32 %dispatch ( src temp offset -- ) M:: x86.32 %dispatch ( src temp -- )
! Load jump table base. ! Load jump table base.
src HEX: ffffffff ADD src HEX: ffffffff ADD
offset cells rc-absolute-cell rel-here 0 rc-absolute-cell rel-here
! Go ! Go
src HEX: 7f [+] JMP src HEX: 7f [+] JMP
! Fix up the displacement above ! Fix up the displacement above
@ -305,10 +306,7 @@ os windows? [
4 "double" c-type (>>align) 4 "double" c-type (>>align)
] unless ] unless
FUNCTION: bool check_sse2 ( ) ; USING: cpu.x86.features cpu.x86.features.private ;
: sse2? ( -- ? )
check_sse2 ;
"-no-sse2" (command-line) member? [ "-no-sse2" (command-line) member? [
[ { check_sse2 } compile ] with-optimizer [ { check_sse2 } compile ] with-optimizer

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

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math namespaces make sequences USING: accessors arrays kernel math namespaces make sequences
system layouts alien alien.c-types alien.accessors alien.structs system layouts alien alien.c-types alien.accessors alien.structs
@ -6,7 +6,7 @@ slots splitting assocs combinators locals cpu.x86.assembler
cpu.x86 cpu.architecture compiler.constants cpu.x86 cpu.architecture compiler.constants
compiler.codegen compiler.codegen.fixup compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.intrinsics ; compiler.cfg.intrinsics compiler.cfg.stack-frame ;
IN: cpu.x86.64 IN: cpu.x86.64
M: x86.64 machine-registers M: x86.64 machine-registers
@ -22,10 +22,10 @@ M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ; M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ; M: x86.64 stack-reg RSP ;
M:: x86.64 %dispatch ( src temp offset -- ) M:: x86.64 %dispatch ( src temp -- )
! Load jump table base. ! Load jump table base.
temp HEX: ffffffff MOV temp HEX: ffffffff MOV
offset cells rc-absolute-cell rel-here 0 rc-absolute-cell rel-here
! Add jump table base ! Add jump table base
src temp ADD src temp ADD
src HEX: 7f [+] JMP src HEX: 7f [+] JMP

8
basis/cpu/x86/assembler/assembler-tests.factor
View File

@ -64,3 +64,11 @@ IN: cpu.x86.assembler.tests
[ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test [ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test
[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test [ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
[ { HEX: 4d HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 R8 3 IMUL3 ] { } make ] unit-test
[ { HEX: 49 HEX: 6b HEX: c0 HEX: 03 } ] [ [ RAX R8 3 IMUL3 ] { } make ] unit-test
[ { HEX: 4c HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 RAX 3 IMUL3 ] { } make ] unit-test
[ { HEX: 48 HEX: 6b HEX: c1 HEX: 03 } ] [ [ RAX RCX 3 IMUL3 ] { } make ] unit-test
[ { HEX: 48 HEX: 69 HEX: c1 HEX: 44 HEX: 03 HEX: 00 HEX: 00 } ] [ [ RAX RCX HEX: 344 IMUL3 ] { } make ] unit-test
[ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test

28
basis/cpu/x86/assembler/assembler.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays io.binary kernel combinators USING: arrays io.binary kernel combinators kernel.private math
kernel.private math namespaces make sequences words system layouts namespaces make sequences words system layouts math.order accessors
math.order accessors cpu.x86.assembler.syntax ; cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler IN: cpu.x86.assembler
! A postfix assembler for x86-32 and x86-64. ! A postfix assembler for x86-32 and x86-64.
@ -402,20 +402,26 @@ M: operand TEST OCT: 204 2-operand ;
: SHR ( dst n -- ) BIN: 101 (SHIFT) ; : SHR ( dst n -- ) BIN: 101 (SHIFT) ;
: SAR ( dst n -- ) BIN: 111 (SHIFT) ; : SAR ( dst n -- ) BIN: 111 (SHIFT) ;
GENERIC: IMUL2 ( dst src -- ) : IMUL2 ( dst src -- )
M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ; OCT: 257 extended-opcode (2-operand) ;
M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
: IMUL3 ( dst src imm -- )
dup fits-in-byte? [
[ swap HEX: 6a 2-operand ] dip 1,
] [
[ swap HEX: 68 2-operand ] dip 4,
] if ;
: MOVSX ( dst src -- ) : MOVSX ( dst src -- )
dup register-32? OCT: 143 OCT: 276 extended-opcode ? swap
over register-16? [ BIN: 1 opcode-or ] when over register-32? OCT: 143 OCT: 276 extended-opcode ?
swapd pick register-16? [ BIN: 1 opcode-or ] when
(2-operand) ; (2-operand) ;
: MOVZX ( dst src -- ) : MOVZX ( dst src -- )
swap
OCT: 266 extended-opcode OCT: 266 extended-opcode
over register-16? [ BIN: 1 opcode-or ] when pick register-16? [ BIN: 1 opcode-or ] when
swapd
(2-operand) ; (2-operand) ;
! Conditional move ! Conditional move

1
basis/cpu/x86/features/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

7
basis/cpu/x86/features/features-tests.factor Normal file
View File

@ -0,0 +1,7 @@
IN: cpu.x86.features.tests
USING: cpu.x86.features tools.test kernel sequences math system ;
cpu x86? [
[ t ] [ sse2? { t f } member? ] unit-test
[ t ] [ [ 10000 [ ] times ] count-instructions integer? ] unit-test
] when

25
basis/cpu/x86/features/features.factor Normal file
View File

@ -0,0 +1,25 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system kernel math alien.syntax ;
IN: cpu.x86.features
<PRIVATE
FUNCTION: bool check_sse2 ( ) ;
FUNCTION: longlong read_timestamp_counter ( ) ;
PRIVATE>
HOOK: sse2? cpu ( -- ? )
M: x86.32 sse2? check_sse2 ;
M: x86.64 sse2? t ;
HOOK: instruction-count cpu ( -- n )
M: x86 instruction-count read_timestamp_counter ;
: count-instructions ( quot -- n )
instruction-count [ call ] dip instruction-count swap - ; inline

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

@ -6,7 +6,7 @@ kernel kernel.private math memory namespaces make sequences
words system layouts combinators math.order fry locals words system layouts combinators math.order fry locals
compiler.constants compiler.cfg.registers compiler.constants compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.intrinsics compiler.cfg.instructions compiler.cfg.intrinsics
compiler.codegen compiler.codegen.fixup ; compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup ;
IN: cpu.x86 IN: cpu.x86
<< enable-fixnum-log2 >> << enable-fixnum-log2 >>
@ -17,6 +17,32 @@ M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
M: x86 two-operand? t ; M: x86 two-operand? t ;
HOOK: stack-reg cpu ( -- reg )
HOOK: reserved-area-size cpu ( -- n )
: stack@ ( n -- op ) stack-reg swap [+] ;
: param@ ( n -- op ) reserved-area-size + stack@ ;
: spill-integer@ ( n -- op ) spill-integer-offset param@ ;
: spill-float@ ( n -- op ) spill-float-offset param@ ;
: gc-root@ ( n -- op ) gc-root-offset param@ ;
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
: incr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
: align-stack ( n -- n' )
os macosx? cpu x86.64? or [ 16 align ] when ;
M: x86 stack-frame-size ( stack-frame -- i )
(stack-frame-size) 3 cells reserved-area-size + + align-stack ;
HOOK: temp-reg-1 cpu ( -- reg ) HOOK: temp-reg-1 cpu ( -- reg )
HOOK: temp-reg-2 cpu ( -- reg ) HOOK: temp-reg-2 cpu ( -- reg )
@ -45,20 +71,6 @@ M: x86 %replace loc>operand swap MOV ;
M: x86 %inc-d ( n -- ) ds-reg (%inc) ; M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
M: x86 %inc-r ( n -- ) rs-reg (%inc) ; M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
: align-stack ( n -- n' )
os macosx? cpu x86.64? or [ 16 align ] when ;
HOOK: reserved-area-size cpu ( -- n )
M: x86 stack-frame-size ( stack-frame -- i )
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
[ params>> ]
[ return>> ]
tri + +
3 cells +
reserved-area-size +
align-stack ;
M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ; M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
: xt-tail-pic-offset ( -- n ) : xt-tail-pic-offset ( -- n )
@ -74,14 +86,11 @@ M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
M: x86 %return ( -- ) 0 RET ; M: x86 %return ( -- ) 0 RET ;
: code-alignment ( align -- n ) : code-alignment ( align -- n )
[ building get [ integer? ] count dup ] dip align swap - ; [ building get length dup ] dip align swap - ;
: align-code ( n -- ) : align-code ( n -- )
0 <repetition> % ; 0 <repetition> % ;
M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
:: (%slot) ( obj slot tag temp -- op ) :: (%slot) ( obj slot tag temp -- op )
temp slot obj [+] LEA temp slot obj [+] LEA
temp tag neg [+] ; inline temp tag neg [+] ; inline
@ -99,7 +108,7 @@ M: x86 %add-imm [+] LEA ;
M: x86 %sub nip SUB ; M: x86 %sub nip SUB ;
M: x86 %sub-imm neg [+] LEA ; M: x86 %sub-imm neg [+] LEA ;
M: x86 %mul nip swap IMUL2 ; M: x86 %mul nip swap IMUL2 ;
M: x86 %mul-imm nip IMUL2 ; M: x86 %mul-imm IMUL3 ;
M: x86 %and nip AND ; M: x86 %and nip AND ;
M: x86 %and-imm nip AND ; M: x86 %and-imm nip AND ;
M: x86 %or nip OR ; M: x86 %or nip OR ;
@ -315,17 +324,29 @@ M:: x86 %box-alien ( dst src temp -- )
"end" resolve-label "end" resolve-label
] with-scope ; ] with-scope ;
: small-reg-4 ( reg -- reg' ) : small-reg-8 ( reg -- reg' )
H{ H{
{ EAX EAX } { EAX RAX }
{ ECX ECX } { ECX RCX }
{ EDX EDX } { EDX RDX }
{ EBX EBX } { EBX RBX }
{ ESP ESP } { ESP RSP }
{ EBP EBP } { EBP RBP }
{ ESI ESP } { ESI RSP }
{ EDI EDI } { EDI RDI }
{ RAX RAX }
{ RCX RCX }
{ RDX RDX }
{ RBX RBX }
{ RSP RSP }
{ RBP RBP }
{ RSI RSP }
{ RDI RDI }
} at ; inline
: small-reg-4 ( reg -- reg' )
small-reg-8 H{
{ RAX EAX } { RAX EAX }
{ RCX ECX } { RCX ECX }
{ RDX EDX } { RDX EDX }
@ -361,12 +382,21 @@ M:: x86 %box-alien ( dst src temp -- )
{ 1 [ small-reg-1 ] } { 1 [ small-reg-1 ] }
{ 2 [ small-reg-2 ] } { 2 [ small-reg-2 ] }
{ 4 [ small-reg-4 ] } { 4 [ small-reg-4 ] }
{ 8 [ small-reg-8 ] }
} case ; } case ;
: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline HOOK: small-regs cpu ( -- regs )
M: x86.32 small-regs { EAX ECX EDX EBX } ;
M: x86.64 small-regs { RAX RCX RDX RBX } ;
HOOK: small-reg-native cpu ( reg -- reg' )
M: x86.32 small-reg-native small-reg-4 ;
M: x86.64 small-reg-native small-reg-8 ;
: small-reg-that-isn't ( exclude -- reg' ) : small-reg-that-isn't ( exclude -- reg' )
small-regs swap [ small-reg-4 ] map '[ _ memq? not ] find nip ; small-regs swap [ small-reg-native ] map '[ _ memq? not ] find nip ;
: with-save/restore ( reg quot -- ) : with-save/restore ( reg quot -- )
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline [ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
@ -376,7 +406,7 @@ M:: x86 %box-alien ( dst src temp -- )
#! call the quot with that. Otherwise, we find a small #! call the quot with that. Otherwise, we find a small
#! register that is not in exclude, and call quot, saving #! register that is not in exclude, and call quot, saving
#! and restoring the small register. #! and restoring the small register.
dst small-reg-4 small-regs memq? [ dst quot call ] [ dst small-reg-native small-regs memq? [ dst quot call ] [
exclude small-reg-that-isn't exclude small-reg-that-isn't
[ quot call ] with-save/restore [ quot call ] with-save/restore
] if ; inline ] if ; inline
@ -492,29 +522,58 @@ M:: x86 %write-barrier ( src card# table -- )
table table [] MOV table table [] MOV
table card# [+] card-mark <byte> MOV ; table card# [+] card-mark <byte> MOV ;
M: x86 %gc ( -- ) :: check-nursery ( temp1 temp2 -- )
"end" define-label temp1 load-zone-ptr
temp-reg-1 load-zone-ptr temp2 temp1 cell [+] MOV
temp-reg-2 temp-reg-1 cell [+] MOV temp2 1024 ADD
temp-reg-2 1024 ADD temp1 temp1 3 cells [+] MOV
temp-reg-1 temp-reg-1 3 cells [+] MOV temp2 temp1 CMP ;
temp-reg-2 temp-reg-1 CMP
"end" get JLE GENERIC# save-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot save-gc-root ( gc-root spill-slot temp -- )
temp spill-slot n>> spill-integer@ MOV
gc-root gc-root@ temp MOV ;
M:: word save-gc-root ( gc-root register temp -- )
gc-root gc-root@ register MOV ;
: save-gc-roots ( gc-roots temp -- )
'[ _ save-gc-root ] assoc-each ;
GENERIC# load-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot load-gc-root ( gc-root spill-slot temp -- )
temp gc-root gc-root@ MOV
spill-slot n>> spill-integer@ temp MOV ;
M:: word load-gc-root ( gc-root register temp -- )
register gc-root gc-root@ MOV ;
: load-gc-roots ( gc-roots temp -- )
'[ _ load-gc-root ] assoc-each ;
:: call-gc ( gc-root-count -- )
! Pass pointer to start of GC roots as first parameter
param-reg-1 gc-root-base param@ LEA
! Pass number of roots as second parameter
param-reg-2 gc-root-count MOV
! Call GC
%prepare-alien-invoke %prepare-alien-invoke
"minor_gc" f %alien-invoke "inline_gc" f %alien-invoke ;
M:: x86 %gc ( temp1 temp2 gc-roots gc-root-count -- )
"end" define-label
temp1 temp2 check-nursery
"end" get JLE
gc-roots temp1 save-gc-roots
gc-root-count call-gc
gc-roots temp1 load-gc-roots
"end" resolve-label ; "end" resolve-label ;
M: x86 %alien-global M: x86 %alien-global
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ; [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
HOOK: stack-reg cpu ( -- reg )
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
: incr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ; M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
:: %boolean ( dst temp word -- ) :: %boolean ( dst temp word -- )
@ -568,28 +627,6 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
{ cc/= [ JNE ] } { cc/= [ JNE ] }
} case ; } case ;
: stack@ ( n -- op ) stack-reg swap [+] ;
: param@ ( n -- op ) reserved-area-size + stack@ ;
: spill-integer-base ( stack-frame -- n )
[ params>> ] [ return>> ] bi + reserved-area-size + ;
: spill-integer@ ( n -- op )
cells
stack-frame get spill-integer-base
+ stack@ ;
: spill-float-base ( stack-frame -- n )
[ spill-integer-base ]
[ spill-counts>> int-regs swap at int-regs reg-size * ]
bi + ;
: spill-float@ ( n -- op )
double-float-regs reg-size *
stack-frame get spill-float-base
+ stack@ ;
M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ; M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ; M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;

11
basis/debugger/debugger.factor
View File

@ -104,8 +104,8 @@ HOOK: signal-error. os ( obj -- )
"Cannot do next-object outside begin/end-scan" print drop ; "Cannot do next-object outside begin/end-scan" print drop ;
: undefined-symbol-error. ( obj -- ) : undefined-symbol-error. ( obj -- )
"The image refers to a library or symbol that was not found" "The image refers to a library or symbol that was not found at load time"
" at load time" append print drop ; print drop ;
: stack-underflow. ( obj name -- ) : stack-underflow. ( obj name -- )
write " stack underflow" print drop ; write " stack underflow" print drop ;
@ -252,12 +252,15 @@ M: no-current-vocab summary
drop "Not in a vocabulary; IN: form required" ; drop "Not in a vocabulary; IN: form required" ;
M: no-word-error summary M: no-word-error summary
name>> "No word named ``" "'' found in current vocabulary search path" surround ; name>>
"No word named ``"
"'' found in current vocabulary search path" surround ;
M: no-word-error error. summary print ; M: no-word-error error. summary print ;
M: ambiguous-use-error summary M: ambiguous-use-error summary
words>> first name>> "More than one vocabulary defines a word named ``" "''" surround ; words>> first name>>
"More than one vocabulary defines a word named ``" "''" surround ;
M: ambiguous-use-error error. summary print ; M: ambiguous-use-error error. summary print ;

4
basis/formatting/formatting-tests.factor
View File

@ -77,6 +77,9 @@ IN: formatting.tests
[ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test [ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test
[ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test [ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test
[ t ] [ "{ 1, 2, 3 }" { 1 2 3 } "%[%s, %]" sprintf = ] unit-test
[ t ] [ "{ 1:2, 3:4 }" H{ { 1 2 } { 3 4 } } "%[%s: %s %]" sprintf = ] unit-test
[ "%H:%M:%S" strftime ] must-infer [ "%H:%M:%S" strftime ] must-infer
@ -95,3 +98,4 @@ IN: formatting.tests
[ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" strftime = ] unit-test [ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" strftime = ] unit-test
[ t ] [ "PM" testtime "%p" strftime = ] unit-test [ t ] [ "PM" testtime "%p" strftime = ] unit-test

5
basis/ftp/server/server.factor
View File

@ -341,12 +341,11 @@ M: ftp-server handle-client* ( server -- )
] with-destructors ; ] with-destructors ;
: <ftp-server> ( directory port -- server ) : <ftp-server> ( directory port -- server )
ftp-server new-threaded-server latin1 ftp-server new-threaded-server
swap >>insecure swap >>insecure
swap canonicalize-path >>serving-directory swap canonicalize-path >>serving-directory
"ftp.server" >>name "ftp.server" >>name
5 minutes >>timeout 5 minutes >>timeout ;
latin1 >>encoding ;
: ftpd ( directory port -- ) : ftpd ( directory port -- )
<ftp-server> start-server ; <ftp-server> start-server ;

19
basis/game-input/dinput/dinput.factor
View File

@ -1,14 +1,13 @@
USING: windows.dinput windows.dinput.constants parser USING: accessors alien alien.c-types alien.strings arrays
alien.c-types windows.ole32 namespaces assocs kernel arrays assocs byte-arrays combinators continuations game-input
vectors windows.kernel32 windows.com windows.dinput shuffle game-input.dinput.keys-array io.encodings.utf16
windows.user32 windows.messages sequences combinators locals io.encodings.utf16n kernel locals math math.bitwise
math.rectangles accessors math alien alien.strings math.rectangles namespaces parser sequences shuffle
io.encodings.utf16 io.encodings.utf16n continuations struct-arrays ui.backend.windows vectors windows.com
byte-arrays game-input.dinput.keys-array game-input windows.dinput windows.dinput.constants windows.errors
ui.backend.windows windows.errors struct-arrays windows.kernel32 windows.messages windows.ole32
math.bitwise ; windows.user32 ;
IN: game-input.dinput IN: game-input.dinput
CONSTANT: MOUSE-BUFFER-SIZE 16 CONSTANT: MOUSE-BUFFER-SIZE 16
SINGLETON: dinput-game-input-backend SINGLETON: dinput-game-input-backend

7
basis/generalizations/generalizations-tests.factor
View File

@ -60,3 +60,10 @@ IN: generalizations.tests
[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ] [ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]
[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test [ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test
[ 1 2 3 4 1 2 3 ] [ 1 2 3 4 3 nover ] unit-test
[ [ 1 2 3 ] [ 1 2 3 ] ]
[ 1 2 3 [ ] [ ] 3 nbi-curry ] unit-test
[ 15 3 ] [ 1 2 3 4 5 [ + + + + ] [ - - - - ] 5 nbi ] unit-test

9
basis/generalizations/generalizations.factor
View File

@ -39,6 +39,9 @@ MACRO: firstn ( n -- )
MACRO: npick ( n -- ) MACRO: npick ( n -- )
1- [ dup ] [ '[ _ dip swap ] ] repeat ; 1- [ dup ] [ '[ _ dip swap ] ] repeat ;
MACRO: nover ( n -- )
dup '[ _ 1 + npick ] n*quot ;
MACRO: ndup ( n -- ) MACRO: ndup ( n -- )
dup '[ _ npick ] n*quot ; dup '[ _ npick ] n*quot ;
@ -69,6 +72,9 @@ MACRO: ncurry ( n -- )
MACRO: nwith ( n -- ) MACRO: nwith ( n -- )
[ with ] n*quot ; [ with ] n*quot ;
MACRO: nbi ( n -- )
'[ [ _ nkeep ] dip call ] ;
MACRO: ncleave ( quots n -- ) MACRO: ncleave ( quots n -- )
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
compose ; compose ;
@ -91,6 +97,9 @@ MACRO: nweave ( n -- )
[ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep [ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
'[ _ _ ncleave ] ; '[ _ _ ncleave ] ;
MACRO: nbi-curry ( n -- )
[ bi-curry ] n*quot ;
: nappend-as ( n exemplar -- seq ) : nappend-as ( n exemplar -- seq )
[ narray concat ] dip like ; inline [ narray concat ] dip like ; inline

3
basis/heaps/heaps.factor
View File

@ -192,6 +192,9 @@ M: heap heap-pop ( heap -- value key )
[ dup heap-pop swap 2array ] [ dup heap-pop swap 2array ]
produce nip ; produce nip ;
: heap-values ( heap -- alist )
data>> [ value>> ] { } map-as ;
: slurp-heap ( heap quot: ( elt -- ) -- ) : slurp-heap ( heap quot: ( elt -- ) -- )
over heap-empty? [ 2drop ] [ over heap-empty? [ 2drop ] [
[ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi

Some files were not shown because too many files have changed in this diff Show More