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.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.accessors assocs byte-arrays combinators
constructors destructors fry io io.binary io.encodings.binary
io.streams.byte-array kernel locals macros math math.ranges
multiline sequences sequences.private vectors byte-vectors
combinators.short-circuit math.bitwise ;
destructors fry io io.binary io.encodings.binary io.streams.byte-array
kernel locals macros math math.ranges multiline sequences
sequences.private vectors byte-vectors combinators.short-circuit
math.bitwise ;
IN: bitstreams
TUPLE: widthed { bits integer read-only } { #bits integer read-only } ;
@ -36,8 +36,12 @@ TUPLE: bit-writer
TUPLE: msb0-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: lsb0-bit-writer < bit-writer ;
@ -56,13 +60,20 @@ TUPLE: lsb0-bit-writer < bit-writer ;
GENERIC: peek ( n bitstream -- value )
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 -- )
{
[ byte-pos>> 8 * ]
[ bit-pos>> + + 8 /mod ]
[ (>>bit-pos) ]
[ (>>byte-pos) ]
} cleave ; inline
[ get-abp + ] [ set-abp ] bi ; inline
: (align) ( n m -- n' )
[ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline
: align ( n bitstream -- )
[ get-abp swap (align) ] [ set-abp ] bi ; inline
: read ( n bitstream -- value )
[ 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
] unless
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
[ [ 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
[ [ 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

4
basis/circular/circular.factor
View File

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

71
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.
USING: kernel math namespaces assocs hashtables sequences arrays
accessors vectors combinators sets classes compiler.cfg
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
! Alias analysis -- assumes compiler.cfg.height has already run.
!
! We try to eliminate redundant slot and stack
! traffic using some simple heuristics.
! We try to eliminate redundant slot operations using some simple heuristics.
!
! All heap-allocated objects which are loaded from the stack, or
! 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.
!
! 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:
!
! int *x, *y, z: inputs
@ -68,15 +63,14 @@ IN: compiler.cfg.alias-analysis
! Map vregs -> alias classes
SYMBOL: vregs>acs
: check ( obj -- obj )
[ "BUG: static type error detected" throw ] unless* ; inline
ERROR: vreg-ac-not-set vreg ;
: vreg>ac ( vreg -- ac )
#! Only vregs produced by ##allot, ##peek and ##slot can
#! ever be used as valid inputs to ##slot and ##set-slot,
#! so we assert this fact by not giving alias classes to
#! other vregs.
vregs>acs get at check ;
vregs>acs get ?at [ vreg-ac-not-set ] unless ;
! Map alias classes -> sequence of vregs
SYMBOL: acs>vregs
@ -122,8 +116,10 @@ SYMBOL: histories
#! value.
over [ live-slots get at at ] [ 2drop f ] if ;
ERROR: vreg-has-no-slots 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 -- )
over [ load-constant-slot ] [ 3drop ] if ;
@ -189,67 +185,49 @@ SYMBOL: constants
GENERIC: insn-slot# ( insn -- slot#/f )
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-imm insn-slot# slot>> ;
M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot-imm insn-slot# slot>> ;
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-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
M: ##alien-global insn-object drop \ ##alien-global ;
: init-alias-analysis ( -- )
: init-alias-analysis ( live-in -- )
H{ } clone histories set
H{ } clone vregs>acs set
H{ } clone acs>vregs set
H{ } clone live-slots set
H{ } clone constants set
H{ } clone copies set
0 ac-counter set
next-ac heap-ac set
ds-loc next-ac set-ac
rs-loc next-ac set-ac ;
[ set-heap-ac ] each ;
GENERIC: analyze-aliases* ( insn -- insn' )
M: ##load-immediate analyze-aliases*
dup [ val>> ] [ dst>> ] bi constants get set-at ;
M: ##load-reference analyze-aliases*
M: ##flushable analyze-aliases*
dup dst>> set-heap-ac ;
M: ##alien-global 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*
M: ##allocation analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
dup dst>> set-new-ac ;
M: ##read analyze-aliases*
dup dst>> set-heap-ac
call-next-method
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
2dup live-slot dup [
2nip f \ ##copy boa analyze-aliases* nip
2nip \ ##copy new-insn analyze-aliases* nip
] [
drop remember-slot
] if ;
@ -292,15 +270,6 @@ GENERIC: eliminate-dead-stores* ( insn -- insn' )
] unless
] 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-imm eliminate-dead-stores* (eliminate-dead-stores) ;
@ -310,8 +279,10 @@ M: insn eliminate-dead-stores* ;
: eliminate-dead-stores ( insns -- insns' )
[ insn# set eliminate-dead-stores* ] map-index sift ;
: alias-analysis ( insns -- insns' )
init-alias-analysis
: alias-analysis-step ( insns -- insns' )
analyze-aliases
compute-live-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.registers
compiler.cfg.intrinsics
compiler.cfg.stack-frame
compiler.cfg.instructions
compiler.alien ;
IN: compiler.cfg.builder
@ -81,30 +82,35 @@ GENERIC: emit-node ( node -- next )
basic-block get successors>> push
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 ] }
{ [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
[ ##epilogue ##jump stop-iterating ]
{ [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] }
[ drop ##epilogue ##jump stop-iterating ]
} cond ;
! #recursive
: compile-recursive ( node -- next )
[ label>> id>> emit-call ]
: recursive-height ( #recursive -- n )
[ 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 ;
: remember-loop ( label -- )
basic-block get swap loops get set-at ;
: compile-loop ( node -- next )
: emit-loop ( node -- next )
##loop-entry
##branch
begin-basic-block
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
iterate-next ;
M: #recursive emit-node
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
! #if
: emit-branch ( obj -- final-bb )
@ -154,65 +160,16 @@ M: #if emit-node
} cond iterate-next ;
! #dispatch
: trivial-dispatch-branch? ( nodes -- ? )
dup length 1 = [
first dup #call? [
word>> "intrinsic" word-prop not
] [ drop f ] if
] [ drop f ] if ;
: dispatch-branch ( nodes word -- label )
over trivial-dispatch-branch? [
drop first word>>
] [
gensym [
[
V{ } clone node-stack set
##prologue
begin-basic-block
emit-nodes
basic-block get [
##epilogue
##return
end-basic-block
] when
] with-cfg-builder
] keep
] if ;
: dispatch-branches ( node -- )
children>> [
current-word get dispatch-branch
##dispatch-label
] each ;
: emit-dispatch ( node -- )
##epilogue
ds-pop ^^offset>slot i 0 ##dispatch
dispatch-branches ;
: <dispatch-block> ( -- word )
gensym dup t "inlined-block" set-word-prop ;
M: #dispatch emit-node
tail-call? [
emit-dispatch stop-iterating
] [
current-word get <dispatch-block> [
[
begin-word
emit-dispatch
] with-cfg-builder
] keep emit-call
] if ;
ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
! #call
M: #call emit-node
dup word>> dup "intrinsic" word-prop
[ emit-intrinsic ] [ nip emit-call ] if ;
[ emit-intrinsic ] [ swap call-height emit-call ] if ;
! #call-recursive
M: #call-recursive emit-node label>> id>> emit-call ;
M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
! #push
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.
USING: kernel arrays vectors accessors namespaces ;
USING: kernel arrays vectors accessors
namespaces math make fry sequences ;
IN: compiler.cfg
TUPLE: basic-block < identity-tuple
id
{ id integer }
number
{ instructions vector }
{ successors vector }
{ predecessors vector } ;
: <basic-block> ( -- basic-block )
M: basic-block hashcode* nip id>> ;
: <basic-block> ( -- bb )
basic-block new
V{ } clone >>instructions
V{ } clone >>successors
V{ } clone >>predecessors
\ 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 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
: resolve ( vreg -- vreg )
dup copies get at swap or ;
[ copies get at ] keep or ;
: record-copy ( insn -- )
[ 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.registers compiler.cfg.stack-frame
compiler.cfg.linear-scan compiler.cfg.two-operand
compiler.cfg.optimizer ;
compiler.cfg.liveness compiler.cfg.optimizer
compiler.cfg.mr ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
@ -18,20 +19,14 @@ M: callable test-cfg
M: word test-cfg
[ build-tree optimize-tree ] keep build-cfg ;
SYMBOL: allocate-registers?
: test-mr ( quot -- mrs )
test-cfg [
optimize-cfg
build-mr
convert-two-operand
allocate-registers? get
[ linear-scan build-stack-frame ] when
] map ;
: insn. ( insn -- )
tuple>array allocate-registers? get [ but-last ] unless
[ pprint bl ] each nl ;
tuple>array [ pprint bl ] each nl ;
: 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.
USING: accessors arrays kernel compiler.cfg.instructions ;
IN: compiler.cfg.def-use
GENERIC: defs-vregs ( insn -- seq )
GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
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: ##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: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
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-setter uses-vregs [ src>> ] [ value>> ] 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: _compare-imm-branch uses-vregs src1>> 1array ;
M: _dispatch uses-vregs src>> 1array ;
M: insn uses-vregs drop f ;
! Instructions that use vregs
UNION: vreg-insn
##flushable
##write-barrier
@ -51,5 +58,8 @@ UNION: vreg-insn
##fixnum-overflow
##conditional-branch
##compare-imm-branch
##phi
##gc
_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
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-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.
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
! Combine multiple stack height changes into one at the
@ -42,10 +43,13 @@ M: ##replace normalize-height* normalize-peek/replace ;
M: insn normalize-height* ;
: normalize-height ( insns -- insns' )
: height-step ( insns -- insns' )
0 ds-height set
0 rs-height set
[ [ compute-heights ] each ]
[ [ [ normalize-height* ] map sift ] with-scope ] bi
ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if
rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ;
ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn 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.
USING: assocs accessors arrays kernel sequences namespaces words
math math.order layouts classes.algebra alien byte-arrays
@ -6,6 +6,8 @@ compiler.constants combinators compiler.cfg.registers
compiler.cfg.instructions.syntax ;
IN: compiler.cfg.instructions
: new-insn ( ... class -- insn ) [ f f ] dip boa ; inline
! Virtual CPU instructions, used by CFG and machine IRs
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: object ##load-literal ##load-reference ;
INSN: ##peek < ##read { loc loc } ;
INSN: ##replace < ##write { loc loc } ;
INSN: ##peek < ##flushable { loc loc } ;
INSN: ##replace < ##effect { loc loc } ;
INSN: ##inc-d { n integer } ;
INSN: ##inc-r { n integer } ;
! Subroutine calls
TUPLE: stack-frame
{ params integer }
{ return integer }
{ total-size integer }
spill-counts ;
INSN: ##stack-frame stack-frame ;
INSN: ##call word ;
INSN: ##call word { height integer } ;
INSN: ##jump word ;
INSN: ##return ;
! Jump tables
INSN: ##dispatch src temp offset ;
INSN: ##dispatch-label label ;
INSN: ##dispatch src temp ;
! Slot access
INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
@ -160,9 +155,12 @@ INSN: ##set-alien-double < ##alien-setter ;
! Memory allocation
INSN: ##allot < ##flushable size class { temp vreg } ;
UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
INSN: ##write-barrier < ##effect card# table ;
INSN: ##alien-global < ##read symbol library ;
INSN: ##alien-global < ##flushable symbol library ;
! FFI
INSN: ##alien-invoke params ;
@ -178,6 +176,8 @@ INSN: ##branch ;
INSN: ##loop-entry ;
INSN: ##phi < ##pure inputs ;
! Condition codes
SYMBOL: cc<
SYMBOL: cc<=
@ -217,16 +217,19 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc temp ;
INSN: ##gc { temp1 vreg } { temp2 vreg } live-registers live-spill-slots ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;
INSN: _epilogue stack-frame ;
INSN: _label id ;
INSN: _gc ;
INSN: _branch label ;
INSN: _dispatch src temp ;
INSN: _dispatch-label label ;
TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
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 ;
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
! virtual registers
INSN: _spill src class n ;
INSN: _reload dst class n ;
INSN: _copy dst src class ;
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-effect ( word -- effect )
boa-effect in>> but-last f <effect> ;
boa-effect in>> 2 head* f <effect> ;
SYNTAX: INSN:
parse-tuple-definition "regs" suffix
parse-tuple-definition { "regs" "insn#" } append
[ dup tuple eq? [ drop insn-word ] when ] dip
[ define-tuple-class ]
[ 2drop save-location ]
[ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
[ 2drop [ ] [ '[ f f _ boa , ] ] [ insn-effect ] tri define-inline ]
3tri ;

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

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

190
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.
USING: namespaces sequences math math.order kernel assocs
accessors vectors fry heaps cpu.architecture combinators
compiler.cfg.registers
compiler.cfg.linear-scan.live-intervals ;
USING: accessors assocs heaps kernel namespaces sequences
compiler.cfg.linear-scan.allocation.coalescing
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.state ;
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 -- )
dup coalesce? [
coalesce
] [
dup vreg>> free-registers-for
[ assign-blocked-register ]
[ assign-free-register ]
dup coalesce? [ coalesce ] [
dup vreg>> free-registers-for [
dup intersecting-inactive
[ assign-blocked-register ]
[ assign-inactive-register ]
if-empty
] [ assign-free-register ]
if-empty
] 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 -- )
[ start>> progress set ]
[ start>> expire-old-intervals ]
[ assign-register ]
tri ;
[
start>>
[ progress set ]
[ deactivate-intervals ]
[ activate-intervals ] tri
] [ assign-register ] bi ;
: (allocate-registers) ( -- )
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 )
#! This modifies the input live-intervals.
init-allocator
dup init-unhandled
(allocate-registers) ;
init-unhandled
(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

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

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

@ -1,15 +1,77 @@
IN: compiler.cfg.linear-scan.tests
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
cpu.architecture
compiler.cfg
compiler.cfg.optimizer
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.liveness
compiler.cfg.predecessors
compiler.cfg.rpo
compiler.cfg.linear-scan
compiler.cfg.linear-scan.live-intervals
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 ;
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 ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
@ -42,46 +104,77 @@ compiler.cfg.linear-scan.debugger ;
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 1 }
{ uses V{ 0 1 } }
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 1 }
{ uses V{ 0 1 } }
{ ranges V{ T{ live-range f 0 1 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
{ 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 } }
} 2 split-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 } } }
} 2 split-for-spill [ f >>split-next ] bi@
] unit-test
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 0 }
{ uses V{ 0 } }
{ ranges V{ T{ live-range f 0 0 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 5 }
{ uses V{ 1 5 } }
{ ranges V{ T{ live-range f 1 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 } } }
} 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 0 }
{ uses V{ 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 1 }
{ start 5 }
{ end 5 }
{ uses V{ 1 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 } }
} 0 split-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
[
@ -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" } } }
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 { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } }
T{ live-interval
{ 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" } } }
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 { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } }
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 } } }
}
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" } } }
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 { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } }
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 } } }
}
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" } } }
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 { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 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 } } }
}
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" } } }
check-linear-scan
@ -240,11 +387,12 @@ SYMBOL: max-uses
max-insns get [ 0 ] replicate taken set
max-insns get [ dup ] H{ } map>assoc available set
[
live-interval new
\ live-interval new
swap int-regs swap vreg boa >>vreg
max-uses get random 2 max [ not-taken ] replicate natural-sort
[ >>uses ] [ first >>start ] bi
dup uses>> last >>end
dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
] map
] with-scope ;
@ -264,45 +412,15 @@ SYMBOL: max-uses
USING: math.private compiler.cfg.debugger ;
[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
[ f ] [
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?
[ ] [
[ float+ float>fixnum 3 fixnum*fast ]
test-cfg first optimize-cfg linear-scan drop
] unit-test
[ 0 1 ] [
{
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ 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
: fake-live-ranges ( seq -- seq' )
[
clone dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
] map ;
! Coalescing interacted badly with splitting
[ ] [
@ -351,7 +469,7 @@ USING: math.private compiler.cfg.debugger ;
{ end 10 }
{ uses V{ 9 10 } }
}
}
} fake-live-ranges
{ { int-regs { 0 1 2 3 } } }
allocate-registers drop
] unit-test
@ -1106,7 +1224,7 @@ USING: math.private compiler.cfg.debugger ;
{ end 109 }
{ uses V{ 103 109 } }
}
}
} fake-live-ranges
{ { int-regs { 0 1 2 3 4 } } }
allocate-registers drop
] unit-test
@ -1199,7 +1317,487 @@ USING: math.private compiler.cfg.debugger ;
{ end 92 }
{ uses V{ 42 45 78 80 92 } }
}
}
} fake-live-ranges
{ { int-regs { 0 1 2 3 } } }
allocate-registers drop
] 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

26
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.
USING: kernel accessors namespaces make
cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.instructions
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.assignment ;
IN: compiler.cfg.linear-scan
@ -23,16 +26,15 @@ IN: compiler.cfg.linear-scan
! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
: (linear-scan) ( insns -- insns' )
dup compute-live-intervals
machine-registers allocate-registers assign-registers ;
: linear-scan ( mr -- mr' )
: (linear-scan) ( rpo machine-registers -- )
[
[
[
(linear-scan) %
spill-counts get _spill-counts
] { } make
] change-instructions
dup number-instructions
dup compute-live-intervals
] dip
allocate-registers assign-registers ;
: linear-scan ( cfg -- cfg' )
[
dup reverse-post-order machine-registers (linear-scan)
spill-counts get >>spill-counts
] 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.
USING: namespaces kernel assocs accessors sequences math fry
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.def-use ;
USING: namespaces kernel assocs accessors sequences math math.order fry
binary-search combinators compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
IN: compiler.cfg.linear-scan.live-intervals
TUPLE: live-range from to ;
C: <live-range> live-range
TUPLE: live-interval
vreg
reg spill-to reload-from split-before split-after
start end uses
reg spill-to reload-from
split-before split-after split-next
start end ranges uses
copy-from ;
: add-use ( n live-interval -- )
dup live-interval? [ "No def" throw ] unless
[ (>>end) ] [ uses>> push ] 2bi ;
: covers? ( insn# live-interval -- ? )
ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
: <live-interval> ( start vreg -- live-interval )
live-interval new
: child-interval-at ( insn# interval -- interval' )
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
swap >>vreg
over >>start
[ add-use ] keep ;
V{ } clone >>ranges
swap >>vreg ;
: block-from ( bb -- n ) instructions>> first insn#>> ;
: block-to ( bb -- n ) instructions>> last insn#>> ;
M: live-interval hashcode*
nip [ start>> ] [ end>> 1000 * ] bi + ;
@ -31,34 +70,77 @@ M: live-interval clone
! Mapping from vreg to live-interval
SYMBOL: live-intervals
: new-live-interval ( n vreg live-intervals -- )
2dup key? [
at add-use
] [
[ [ <live-interval> ] keep ] dip set-at
] if ;
: live-interval ( vreg live-intervals -- live-interval )
[ <live-interval> ] cache ;
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*
dup insn#>>
live-intervals get
[ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
[ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
3bi ;
[ [ defs-vregs ] 2dip '[ [ _ ] dip _ handle-output ] each ]
[ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ]
[ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
3tri ;
: record-copy ( insn -- )
[ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
M: ##copy compute-live-intervals*
[ call-next-method ] [ drop record-copy ] 2bi ;
[ call-next-method ] [ record-copy ] bi ;
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 [
live-intervals set
[ compute-live-intervals* ] each-index
] keep values ;
<reversed> [ compute-live-intervals-step ] each
] 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.
USING: kernel math accessors sequences namespaces make
combinators classes
combinators assocs arrays locals cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.liveness
compiler.cfg.stack-frame
compiler.cfg.instructions ;
IN: compiler.cfg.linearization
! Convert CFG IR to machine IR.
GENERIC: linearize-insn ( basic-block insn -- )
: linearize-insns ( basic-block -- )
dup instructions>> [ linearize-insn ] with each ; inline
: linearize-basic-block ( bb -- )
[ number>> _label ]
[ dup instructions>> [ linearize-insn ] with each ]
bi ;
M: insn linearize-insn , drop ;
: useless-branch? ( basic-block successor -- ? )
#! If our successor immediately follows us in RPO, then we
#! don't need to branch.
[ number>> ] bi@ 1- = ; inline
[ number>> ] bi@ 1 - = ; inline
: branch-to-branch? ( successor -- ? )
#! 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 -- )
{
{ [ 2dup useless-branch? ] [ 2drop ] }
{ [ dup branch-to-branch? ] [ nip linearize-insns ] }
{ [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
[ nip number>> _branch ]
} cond ;
@ -46,35 +50,82 @@ M: ##branch linearize-insn
[ drop dup successors>> second useless-branch? ] 2bi
[ [ 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
binary-conditional _compare-branch emit-branch ;
[ binary-conditional _compare-branch ] with-regs emit-branch ;
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
binary-conditional _compare-float-branch emit-branch ;
[ binary-conditional _compare-float-branch ] with-regs emit-branch ;
: gc? ( bb -- ? )
instructions>> [
class {
##allot
##integer>bignum
##box-float
##box-alien
} memq?
] any? ;
M: ##dispatch linearize-insn
swap
[ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
[ successors>> [ number>> _dispatch-label ] each ]
bi* ;
: linearize-basic-block ( bb -- )
[ number>> _label ]
[ gc? [ _gc ] when ]
[ linearize-insns ]
tri ;
: gc-root-registers ( n live-registers -- n )
[
[ second 2array , ]
[ first reg-class>> reg-size + ]
2bi
] each ;
: linearize-basic-blocks ( rpo -- insns )
[ [ linearize-basic-block ] each ] { } make ;
: gc-root-spill-slots ( n live-spill-slots -- n )
[
dup first reg-class>> int-regs eq? [
[ second <spill-slot> 2array , ]
[ first reg-class>> reg-size + ]
2bi
] [ drop ] if
] each ;
: build-mr ( cfg -- mr )
[ entry>> reverse-post-order linearize-basic-blocks ]
[ word>> ] [ label>> ]
tri <mr> ;
: oop-registers ( regs -- regs' )
[ first reg-class>> int-regs eq? ] filter ;
: 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

46
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.
USING: kernel sequences compiler.cfg.rpo
compiler.cfg.instructions
USING: kernel sequences accessors combinators namespaces
compiler.cfg.predecessors
compiler.cfg.useless-blocks
compiler.cfg.height
compiler.cfg.stack-analysis
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
compiler.cfg.dead-code
compiler.cfg.write-barrier ;
compiler.cfg.dce
compiler.cfg.write-barrier
compiler.cfg.liveness
compiler.cfg.rpo
compiler.cfg.phi-elimination
compiler.cfg.checker ;
IN: compiler.cfg.optimizer
: trivial? ( insns -- ? )
dup length 2 = [ first ##call? ] [ drop f ] if ;
SYMBOL: check-optimizer?
: ?check ( cfg -- cfg' )
check-optimizer? get [
dup check-cfg
] when ;
: optimize-cfg ( cfg -- cfg' )
compute-predecessors
delete-useless-blocks
delete-useless-conditionals
[
dup trivial? [
normalize-height
alias-analysis
value-numbering
eliminate-dead-code
eliminate-write-barriers
] unless
] change-basic-blocks ;
compute-predecessors
delete-useless-blocks
delete-useless-conditionals
normalize-height
stack-analysis
compute-liveness
alias-analysis
value-numbering
eliminate-dead-code
eliminate-write-barriers
eliminate-phis
?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.
USING: kernel accessors sequences compiler.cfg.rpo ;
IN: compiler.cfg.predecessors
: (compute-predecessors) ( bb -- )
: predecessors-step ( bb -- )
dup successors>> [ predecessors>> push ] with each ;
: 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.
USING: kernel accessors namespaces make math sequences sets
assocs fry compiler.cfg compiler.cfg.instructions ;
@ -7,29 +7,29 @@ IN: compiler.cfg.rpo
SYMBOL: visited
: post-order-traversal ( bb -- )
dup id>> visited get key? [ drop ] [
dup id>> visited get conjoin
dup visited get key? [ drop ] [
dup visited get conjoin
[
successors>> <reversed>
[ post-order-traversal ] each
] [ , ] bi
] if ;
: post-order ( bb -- blocks )
[ post-order-traversal ] { } make ;
: number-blocks ( blocks -- )
[ >>number drop ] each-index ;
dup length iota <reversed>
[ >>number drop ] 2each ;
: reverse-post-order ( bb -- blocks )
H{ } clone visited [
post-order <reversed> dup number-blocks
] with-variable ; inline
: post-order ( cfg -- blocks )
dup post-order>> [ ] [
[
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 -- )
[ entry>> reverse-post-order ] dip each ; inline
: change-basic-blocks ( cfg quot -- cfg' )
[ '[ _ change-instructions drop ] each-basic-block ]
[ drop ]
2bi ; inline
[ reverse-post-order ] dip each ; 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.
USING: namespaces accessors math.order assocs kernel sequences
combinators make classes words cpu.architecture
compiler.cfg.instructions compiler.cfg.registers ;
USING: math math.order namespaces accessors kernel layouts combinators
combinators.smart assocs sequences cpu.architecture ;
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 )
[ stack-frame new ] 2dip
[ [ params>> ] bi@ max >>params ]
[ [ return>> ] bi@ max >>return ]
2bi ;
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 ;
[ [ gc-root-size>> ] bi@ max >>gc-root-size ]
2tri ;

55
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.
USING: accessors arrays kernel sequences compiler.utilities
compiler.cfg.instructions cpu.architecture ;
USING: accessors kernel sequences make compiler.cfg.instructions
compiler.cfg.local cpu.architecture ;
IN: compiler.cfg.two-operand
! On x86, instructions take the form x = x op y
! Our SSA IR is x = y op z
! We don't bother with ##add, ##add-imm or ##sub-imm since x86
! has a LEA instruction which is effectively a three-operand
! addition
! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm
! since x86 has LEA and IMUL instructions which are effectively
! 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 )
[ [ dst>> ] [ src1>> ] bi make-copy ]
[ dup dst>> >>src1 ]
bi 2array ; inline
: convert-two-operand/integer ( insn -- )
[ [ dst>> ] [ src1>> ] bi ##copy ]
[ dup dst>> >>src1 , ]
bi ; inline
: convert-two-operand/float ( insn -- insns )
[ [ dst>> ] [ src1>> ] bi make-copy/float ]
[ dup dst>> >>src1 ]
bi 2array ; inline
: convert-two-operand/float ( insn -- )
[ [ dst>> ] [ src1>> ] bi ##copy-float ]
[ dup dst>> >>src1 , ]
bi ; inline
GENERIC: convert-two-operand* ( insn -- insns )
GENERIC: convert-two-operand* ( insn -- )
M: ##not convert-two-operand*
[ [ dst>> ] [ src>> ] bi make-copy ]
[ dup dst>> >>src ]
bi 2array ;
[ [ dst>> ] [ src>> ] bi ##copy ]
[ dup dst>> >>src , ]
bi ;
M: ##sub 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-imm 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: ##div-float convert-two-operand* convert-two-operand/float ;
M: insn convert-two-operand* ;
M: insn convert-two-operand* , ;
: convert-two-operand ( mr -- mr' )
[
two-operand? [
[ convert-two-operand* ] map-flat
] when
] change-instructions ;
: convert-two-operand ( cfg -- cfg' )
two-operand? [
[ drop ]
[ [ [ convert-two-operand* ] each ] V{ } make ]
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.
USING: kernel accessors sequences combinators classes vectors
compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ;
USING: kernel accessors sequences combinators combinators.short-circuit
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.useless-blocks
: 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 [
[
2dup eq? [ drop successors>> first ] [ nip ] if
@ -12,9 +14,13 @@ IN: compiler.cfg.useless-blocks
] change-successors drop ;
: update-successor-for-delete ( bb -- )
[ predecessors>> first ]
[ successors>> first predecessors>> ]
bi set-first ;
! We have to replace occurrences of bb with bb's predecessor
! in bb's sucessor's list of predecessors.
dup successors>> first [
[
2dup eq? [ drop predecessors>> first ] [ nip ] if
] with map
] change-predecessors drop ;
: delete-basic-block ( bb -- )
[ update-predecessor-for-delete ]
@ -23,17 +29,17 @@ IN: compiler.cfg.useless-blocks
: delete-basic-block? ( bb -- ? )
{
{ [ dup instructions>> length 1 = not ] [ f ] }
{ [ dup predecessors>> length 1 = not ] [ f ] }
{ [ dup successors>> length 1 = not ] [ f ] }
{ [ dup instructions>> first ##branch? not ] [ f ] }
[ t ]
} cond nip ;
[ instructions>> length 1 = ]
[ predecessors>> length 1 = ]
[ successors>> length 1 = ]
[ instructions>> first ##branch? ]
} 1&& ;
: delete-useless-blocks ( cfg -- cfg' )
dup [
dup delete-basic-block? [ delete-basic-block ] [ drop ] if
] each-basic-block ;
] each-basic-block
f >>post-order ;
: delete-conditional? ( bb -- ? )
dup instructions>> [ drop f ] [
@ -46,10 +52,11 @@ IN: compiler.cfg.useless-blocks
: delete-conditional ( bb -- )
dup successors>> first 1vector >>successors
[ but-last f \ ##branch boa suffix ] change-instructions
[ but-last \ ##branch new-insn suffix ] change-instructions
drop ;
: delete-useless-conditionals ( cfg -- cfg' )
dup [
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 ;
: call-height ( ##call -- n )
[ out-d>> length ] [ in-d>> length ] bi - ;
: 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
] [ 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
! can eliminate a second computation having the same 'n' as
! the first one; we can also eliminate input-exprs whose
! result is not used.
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
GENERIC: >expr ( insn -- expr )
@ -80,7 +80,7 @@ M: ##compare-imm >expr compare-imm>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 ( -- )
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
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
] [ drop ] if ;
@ -36,9 +36,9 @@ M: ##mul-imm rewrite
: rewrite-boolean-comparison ( expr -- insn )
src1>> vreg>expr dup op>> {
{ \ ##compare [ >compare-expr< f \ ##compare-branch boa ] }
{ \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] }
{ \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] }
{ \ ##compare [ >compare-expr< \ ##compare-branch new-insn ] }
{ \ ##compare-imm [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
{ \ ##compare-float [ >compare-expr< \ ##compare-float-branch new-insn ] }
} case ;
: tag-fixnum-expr? ( expr -- ? )
@ -60,11 +60,11 @@ M: ##mul-imm rewrite
GENERIC: rewrite-tagged-comparison ( insn -- insn' )
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
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
i f \ ##compare-imm boa ;
i \ ##compare-imm new-insn ;
M: ##compare-imm-branch rewrite
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
@ -79,7 +79,7 @@ M: ##compare-imm-branch rewrite
[ dst>> ]
[ src2>> ]
[ src1>> vreg>vn vn>constant ] tri
cc= f i \ ##compare-imm boa ;
cc= i \ ##compare-imm new-insn ;
M: ##compare rewrite
dup flip-comparison? [
@ -96,9 +96,9 @@ M: ##compare rewrite
: rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
{ \ ##compare [ >compare-expr< i f \ ##compare boa ] }
{ \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] }
{ \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] }
{ \ ##compare [ >compare-expr< i \ ##compare new-insn ] }
{ \ ##compare-imm [ >compare-imm-expr< i \ ##compare-imm new-insn ] }
{ \ ##compare-float [ >compare-expr< i \ ##compare-float new-insn ] }
} case
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
@ -114,18 +114,4 @@ M: ##compare-imm rewrite
] 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 ;

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
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
tools.test kernel math combinators.short-circuit accessors
sequences ;
sequences compiler.cfg vectors arrays ;
: trim-temps ( insns -- insns )
[
@ -13,6 +13,10 @@ sequences ;
} 1|| [ f >>temp ] when
] map ;
: test-value-numbering ( insns -- insns )
{ } init-value-numbering
value-numbering-step ;
[
{
T{ ##peek f V int-regs 45 D 1 }
@ -24,7 +28,7 @@ sequences ;
T{ ##peek f V int-regs 45 D 1 }
T{ ##copy f V int-regs 48 V int-regs 45 }
T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
} value-numbering
} test-value-numbering
] unit-test
[
@ -40,14 +44,14 @@ sequences ;
T{ ##peek f V int-regs 3 D 0 }
T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
T{ ##replace f V int-regs 4 D 0 }
} value-numbering
} test-value-numbering
] unit-test
[ t ] [
{
T{ ##peek f V int-regs 1 D 0 }
T{ ##dispatch f V int-regs 1 V int-regs 2 0 }
} dup value-numbering =
T{ ##dispatch f V int-regs 1 V int-regs 2 }
} dup test-value-numbering =
] unit-test
[ t ] [
@ -60,7 +64,7 @@ sequences ;
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{ ##replace f V int-regs 23 D 0 }
} dup value-numbering =
} dup test-value-numbering =
] unit-test
[
@ -76,7 +80,7 @@ sequences ;
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{ ##replace f V int-regs 3 D 0 }
} value-numbering
} test-value-numbering
] 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-imm f V int-regs 6 V int-regs 4 5 cc/= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering trim-temps
} test-value-numbering trim-temps
] 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-imm f V int-regs 6 V int-regs 4 5 cc= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering trim-temps
} test-value-numbering trim-temps
] 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-imm f V int-regs 14 V int-regs 12 5 cc= }
T{ ##replace f V int-regs 14 D 0 }
} value-numbering trim-temps
} test-value-numbering trim-temps
] unit-test
[
@ -150,5 +154,18 @@ sequences ;
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-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

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

@ -2,6 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs biassocs classes kernel math accessors
sorting sets sequences
compiler.cfg.local
compiler.cfg.liveness
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions
compiler.cfg.value-numbering.propagate
@ -9,7 +11,16 @@ compiler.cfg.value-numbering.simplify
compiler.cfg.value-numbering.rewrite ;
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-expressions
number-input-values ;
: value-numbering-step ( insns -- insns' )
[ [ 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
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
: test-write-barrier ( insns -- insns )
write-barriers-step ;
[
{
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{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
T{ ##replace f V int-regs 7 D 0 }
} eliminate-write-barriers
} test-write-barrier
] unit-test
[
@ -42,7 +45,7 @@ IN: compiler.cfg.write-barrier.tests
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{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
} eliminate-write-barriers
} test-write-barrier
] unit-test
[
@ -69,5 +72,5 @@ IN: compiler.cfg.write-barrier.tests
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{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
} eliminate-write-barriers
} test-write-barrier
] 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.
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
! Eliminate redundant write barrier hits.
@ -35,8 +36,11 @@ M: ##set-slot-imm eliminate-write-barrier
M: insn eliminate-write-barrier ;
: eliminate-write-barriers ( insns -- insns' )
: write-barriers-step ( insns -- insns' )
H{ } clone safe set
H{ } clone mutated set
H{ } clone copies set
[ 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
compiler.errors
compiler.alien
compiler.constants
compiler.cfg
compiler.cfg.instructions
compiler.cfg.stack-frame
compiler.cfg.registers
compiler.cfg.builder
compiler.codegen.fixup
@ -26,14 +28,6 @@ SYMBOL: registers
: ?register ( obj -- operand )
dup vreg? [ register ] when ;
: generate-insns ( insns -- code )
[
[
dup regs>> registers set
generate-insn
] each
] { } make fixup ;
TUPLE: asm label code calls ;
SYMBOL: calls
@ -51,17 +45,22 @@ SYMBOL: labels
: init-generator ( word -- )
H{ } clone labels set
V{ } clone literal-table set
V{ } clone calls set
compiling-word set
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 )
[
[ label>> ]
[ word>> init-generator ]
[ instructions>> generate-insns ] tri
calls get
[ label>> ] [ generate-insns ] bi calls get
asm boa
] with-scope ;
@ -92,10 +91,13 @@ M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
M: ##return generate-insn drop %return ;
M: ##dispatch-label generate-insn label>> %dispatch-label ;
M: _dispatch generate-insn
[ src>> register ] [ temp>> register ] bi %dispatch ;
M: ##dispatch generate-insn
[ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
M: _dispatch-label generate-insn
label>> lookup-label
cell 0 <repetition> %
rc-absolute-cell label-fixup ;
: >slot< ( insn -- dst obj slot tag )
{
@ -236,7 +238,13 @@ M: ##write-barrier generate-insn
[ table>> register ]
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 ;
@ -245,16 +253,6 @@ M: ##alien-global generate-insn
%alien-global ;
! ##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 )
M: reg-class reg-class-variable ;
@ -486,7 +484,7 @@ M: _epilogue generate-insn
stack-frame>> total-size>> %epilogue ;
M: _label generate-insn
id>> lookup-label , ;
id>> lookup-label resolve-label ;
M: _branch generate-insn
label>> lookup-label %jump-label ;
@ -533,4 +531,10 @@ M: _reload generate-insn
{ double-float-regs [ %reload-float ] }
} case ;
M: _copy generate-insn
[ dst>> ] [ src>> ] [ class>> ] tri {
{ int-regs [ %copy ] }
{ double-float-regs [ %copy-float ] }
} case ;
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
words quotations strings alien.accessors alien.strings layouts
system combinators math.bitwise math.order
accessors growable cpu.architecture compiler.constants ;
accessors growable compiler.constants ;
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 ;
: 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: 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 -- )
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
M: rel-fixup fixup*
[ type>> ]
[ class>> ]
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] tri
{ 0 24 28 } bitfield
relocation-table get push-4 ;
: add-relocation-entry ( type class offset -- )
{ 0 24 28 } bitfield relocation-table get push-4 ;
M: integer fixup* , ;
SYMBOL: literal-table
: add-literal ( obj -- ) literal-table get push ;
: rel-fixup ( class type -- )
swap dup offset-for-class add-relocation-entry ;
: add-dlsym-literals ( symbol dll -- )
[ string>symbol add-literal ] [ add-literal ] bi* ;
@ -74,22 +74,34 @@ SYMBOL: literal-table
: rel-here ( offset class -- )
[ 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 ( -- )
BV{ } clone relocation-table set
V{ } clone label-table set ;
V{ } clone literal-table set
V{ } clone label-table set
BV{ } clone relocation-table set ;
: resolve-labels ( labels -- labels' )
[
first3 offset>>
[ "Unresolved label" throw ] unless*
3array
] map concat ;
: fixup ( fixup-directives -- code )
: with-fixup ( quot -- code )
[
init-fixup
[ fixup* ] each
call
label-table [ resolve-labels ] change
literal-table get >array
relocation-table get >byte-array
label-table get resolve-labels
] B{ } make 4array ;
label-table get
] B{ } make 4array ; inline

43
basis/compiler/compiler.factor
View File

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

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

@ -327,4 +327,11 @@ C: <ro-box> ro-box
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

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

@ -25,18 +25,20 @@ SYMBOL: check-optimizer?
] when ;
: optimize-tree ( nodes -- nodes' )
analyze-recursive
normalize
propagate
cleanup
dup run-escape-analysis? [
escape-analysis
unbox-tuples
] when
apply-identities
compute-def-use
remove-dead-code
?check
compute-def-use
optimize-modular-arithmetic
finalize ;
[
analyze-recursive
normalize
propagate
cleanup
dup run-escape-analysis? [
escape-analysis
unbox-tuples
] when
apply-identities
compute-def-use
remove-dead-code
?check
compute-def-use
optimize-modular-arithmetic
finalize
] with-scope ;

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

@ -1,6 +1,6 @@
! Copyright (C) 2009 Marc Fauconneau.
! 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
math.ranges multiline sequences ;
IN: compression.huffman
@ -58,7 +58,10 @@ TUPLE: huffman-decoder
{ rtable }
{ bits/level } ;
CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder )
: <huffman-decoder> ( bs tdesc -- decoder )
huffman-decoder new
swap >>tdesc
swap >>bs
16 >>bits/level
[ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;

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

@ -1,212 +1,220 @@
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays
byte-vectors combinators constructors fry grouping hashtables
compression.huffman images io.binary kernel locals
math math.bitwise math.order math.ranges multiline sequences
sorting ;
IN: compression.inflate
QUALIFIED-WITH: bitstreams bs
<PRIVATE
: enum>seq ( assoc -- seq )
dup keys [ ] [ max ] map-reduce 1 + f <array>
[ '[ swap _ set-nth ] assoc-each ] keep ;
ERROR: zlib-unimplemented ;
ERROR: bad-zlib-data ;
ERROR: bad-zlib-header ;
:: check-zlib-header ( data -- )
16 data bs:peek 2 >le be> 31 mod ! checksum
0 assert=
4 data bs:read 8 assert= ! compression method: deflate
4 data bs:read ! log2(max length)-8, 32K max
7 <= [ bad-zlib-header ] unless
5 data bs:seek ! drop check bits
1 data bs:read 0 assert= ! dictionnary - not allowed in png
2 data bs:seek ! compression level; ignore
;
:: default-table ( -- table )
0 <hashtable> :> table
0 143 [a,b] 280 287 [a,b] append 8 table set-at
144 255 [a,b] >array 9 table set-at
256 279 [a,b] >array 7 table set-at
table enum>seq 1 tail ;
CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
: get-table ( values size -- table )
16 f <array> clone <enum>
[ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
:: decode-huffman-tables ( bitstream -- tables )
5 bitstream bs:read 257 +
5 bitstream bs:read 1 +
4 bitstream bs:read 4 +
clen-shuffle swap head
dup [ drop 3 bitstream bs:read ] map
get-table
bitstream swap <huffman-decoder>
[ 2dup + ] dip swap :> k!
'[
_ read1-huff2
{
{ [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
{ [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
{ [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
[ ]
} cond
dup array? [ dup second ] [ 1 ] if
k swap - dup k! 0 >
]
[ ] produce swap suffix
{ } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
[ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
CONSTANT: length-table
{
3 4 5 6 7 8 9 10
11 13 15 17
19 23 27 31
35 43 51 59
67 83 99 115
131 163 195 227 258
}
CONSTANT: dist-table
{
1 2 3 4
5 7 9 13
17 25 33 49
65 97 129 193
257 385 513 769
1025 1537 2049 3073
4097 6145 8193 12289
16385 24577
}
: nth* ( n seq -- elt )
[ length 1- swap - ] [ nth ] bi ;
:: inflate-lz77 ( seq -- bytes )
1000 <byte-vector> :> bytes
seq
[
dup array?
[ first2 '[ _ 1- bytes nth* bytes push ] times ]
[ bytes push ] if
] each
bytes ;
:: inflate-dynamic ( bitstream -- bytes )
bitstream decode-huffman-tables
bitstream '[ _ swap <huffman-decoder> ] map :> tables
[
tables first read1-huff2
dup 256 >
[
dup 285 =
[ ]
[
dup 264 >
[
dup 261 - 4 /i dup 5 >
[ bad-zlib-data ] when
bitstream bs:read 2array
]
when
] if
! 5 bitstream read-bits ! distance
tables second read1-huff2
dup 3 >
[
dup 2 - 2 /i dup 13 >
[ bad-zlib-data ] when
bitstream bs:read 2array
]
when
2array
]
when
dup 256 = not
]
[ ] produce nip
[
dup array? [
first2
[
dup array? [ first2 ] [ 0 ] if
[ 257 - length-table nth ] [ + ] bi*
]
[
dup array? [ first2 ] [ 0 ] if
[ dist-table nth ] [ + ] bi*
] bi*
2array
] when
] map ;
: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ;
: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
:: inflate-loop ( bitstream -- bytes )
[ 1 bitstream bs:read 0 = ]
[
bitstream
2 bitstream bs:read
{
{ 0 [ inflate-raw ] }
{ 1 [ inflate-static ] }
{ 2 [ inflate-dynamic ] }
{ 3 [ bad-zlib-data f ] }
}
case
]
[ produce ] keep call suffix concat ;
! [ produce ] keep dip swap suffix
:: paeth ( a b c -- p )
a b + c - { a b c } [ [ - abs ] keep 2array ] with map
sort-keys first second ;
:: png-unfilter-line ( prev curr filter -- curr' )
prev :> c
prev 3 tail-slice :> b
curr :> a
curr 3 tail-slice :> x
x length [0,b)
filter
{
{ 0 [ drop ] }
{ 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
{ 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
{ 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
{ 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
} case
curr 3 tail ;
PRIVATE>
! for debug -- shows residual values
: reverse-png-filter' ( lines -- filtered )
[ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
concat [ 128 + 256 wrap ] map ;
: reverse-png-filter ( lines -- filtered )
dup first [ 0 ] replicate prefix
[ { 0 0 } prepend ] map
2 clump [
first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
] map concat ;
: zlib-inflate ( bytes -- bytes )
bs:<lsb0-bit-reader>
[ check-zlib-header ] [ inflate-loop ] bi
inflate-lz77 ;
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays
byte-vectors combinators fry grouping hashtables
compression.huffman images io.binary kernel locals
math math.bitwise math.order math.ranges multiline sequences
sorting ;
IN: compression.inflate
QUALIFIED-WITH: bitstreams bs
<PRIVATE
: enum>seq ( assoc -- seq )
dup keys [ ] [ max ] map-reduce 1 + f <array>
[ '[ swap _ set-nth ] assoc-each ] keep ;
ERROR: zlib-unimplemented ;
ERROR: bad-zlib-data ;
ERROR: bad-zlib-header ;
:: check-zlib-header ( data -- )
16 data bs:peek 2 >le be> 31 mod ! checksum
0 assert=
4 data bs:read 8 assert= ! compression method: deflate
4 data bs:read ! log2(max length)-8, 32K max
7 <= [ bad-zlib-header ] unless
5 data bs:seek ! drop check bits
1 data bs:read 0 assert= ! dictionnary - not allowed in png
2 data bs:seek ! compression level; ignore
;
:: default-table ( -- table )
0 <hashtable> :> table
0 143 [a,b] 280 287 [a,b] append 8 table set-at
144 255 [a,b] >array 9 table set-at
256 279 [a,b] >array 7 table set-at
table enum>seq 1 tail ;
CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
: get-table ( values size -- table )
16 f <array> clone <enum>
[ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
:: decode-huffman-tables ( bitstream -- tables )
5 bitstream bs:read 257 +
5 bitstream bs:read 1 +
4 bitstream bs:read 4 +
clen-shuffle swap head
dup [ drop 3 bitstream bs:read ] map
get-table
bitstream swap <huffman-decoder>
[ 2dup + ] dip swap :> k!
'[
_ read1-huff2
{
{ [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
{ [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
{ [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
[ ]
} cond
dup array? [ dup second ] [ 1 ] if
k swap - dup k! 0 >
]
[ ] produce swap suffix
{ } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
[ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
CONSTANT: length-table
{
3 4 5 6 7 8 9 10
11 13 15 17
19 23 27 31
35 43 51 59
67 83 99 115
131 163 195 227 258
}
CONSTANT: dist-table
{
1 2 3 4
5 7 9 13
17 25 33 49
65 97 129 193
257 385 513 769
1025 1537 2049 3073
4097 6145 8193 12289
16385 24577
}
: nth* ( n seq -- elt )
[ length 1- swap - ] [ nth ] bi ;
:: inflate-lz77 ( seq -- bytes )
1000 <byte-vector> :> bytes
seq
[
dup array?
[ first2 '[ _ 1- bytes nth* bytes push ] times ]
[ bytes push ] if
] each
bytes ;
:: inflate-dynamic ( bitstream -- bytes )
bitstream decode-huffman-tables
bitstream '[ _ swap <huffman-decoder> ] map :> tables
[
tables first read1-huff2
dup 256 >
[
dup 285 =
[ ]
[
dup 264 >
[
dup 261 - 4 /i dup 5 >
[ bad-zlib-data ] when
bitstream bs:read 2array
]
when
] if
! 5 bitstream read-bits ! distance
tables second read1-huff2
dup 3 >
[
dup 2 - 2 /i dup 13 >
[ bad-zlib-data ] when
bitstream bs:read 2array
]
when
2array
]
when
dup 256 = not
]
[ ] produce nip
[
dup array? [
first2
[
dup array? [ first2 ] [ 0 ] if
[ 257 - length-table nth ] [ + ] bi*
]
[
dup array? [ first2 ] [ 0 ] if
[ dist-table nth ] [ + ] bi*
] bi*
2array
] when
] map ;
:: 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-loop ( bitstream -- bytes )
[ 1 bitstream bs:read 0 = ]
[
bitstream
2 bitstream bs:read
{
{ 0 [ inflate-raw ] }
{ 1 [ inflate-static ] }
{ 2 [ inflate-dynamic ] }
{ 3 [ bad-zlib-data f ] }
}
case
]
[ produce ] keep call suffix concat ;
! [ produce ] keep dip swap suffix
:: paeth ( a b c -- p )
a b + c - { a b c } [ [ - abs ] keep 2array ] with map
sort-keys first second ;
:: png-unfilter-line ( prev curr filter -- curr' )
prev :> c
prev 3 tail-slice :> b
curr :> a
curr 3 tail-slice :> x
x length [0,b)
filter
{
{ 0 [ drop ] }
{ 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
{ 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
{ 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
{ 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
} case
curr 3 tail ;
PRIVATE>
: reverse-png-filter' ( lines -- byte-array )
[ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
concat [ 128 + ] B{ } map-as ;
: reverse-png-filter ( lines -- byte-array )
dup first [ 0 ] replicate prefix
[ { 0 0 } prepend ] map
2 clump [
first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
] map B{ } concat-as ;
: zlib-inflate ( bytes -- bytes )
bs:<lsb0-bit-reader>
[ check-zlib-header ] [ inflate-loop ] bi
inflate-lz77 ;

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* ;
: <node-server> ( addrspec -- threaded-server )
<threaded-server>
binary <threaded-server>
swap >>insecure
binary >>encoding
"concurrency.distributed" >>name
[ 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 ;
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
SINGLETON: int-regs
SINGLETON: single-float-regs
@ -19,12 +12,22 @@ SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-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
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
GENERIC: return-reg ( register-class -- reg )
@ -51,8 +54,7 @@ HOOK: %jump cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- )
HOOK: %dispatch cpu ( src temp offset -- )
HOOK: %dispatch-label cpu ( word -- )
HOOK: %dispatch cpu ( src temp -- )
HOOK: %slot cpu ( dst obj slot tag temp -- )
HOOK: %slot-imm cpu ( dst obj slot tag -- )
@ -126,7 +128,7 @@ HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %allot cpu ( dst size class temp -- )
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: %epilogue cpu ( n -- )

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

@ -3,10 +3,11 @@
USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words
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.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 ;
IN: cpu.ppc
@ -124,16 +125,13 @@ M: ppc %jump ( word -- )
M: ppc %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ;
M:: ppc %dispatch ( src temp offset -- )
M:: ppc %dispatch ( src temp -- )
0 temp LOAD32
4 offset + cells rc-absolute-ppc-2/2 rel-here
4 cells rc-absolute-ppc-2/2 rel-here
temp temp src LWZX
temp MTCTR
BCTR ;
M: ppc %dispatch-label ( word -- )
B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
:: (%slot) ( obj slot tag temp -- reg offset )
temp slot obj ADD
temp tag neg ; inline
@ -464,16 +462,18 @@ M:: ppc %write-barrier ( src card# table -- )
src card# deck-bits SRWI
table scratch-reg card# STBX ;
M: ppc %gc
M:: ppc %gc ( temp1 temp2 gc-roots gc-root-count -- )
"end" define-label
12 load-zone-ptr
11 12 cell LWZ ! nursery.here -> r11
12 12 3 cells LWZ ! nursery.end -> r12
11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
11 0 12 CMP ! is here >= end?
temp2 load-zone-ptr
temp1 temp2 cell LWZ
temp2 temp2 3 cells LWZ
temp1 temp1 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
temp1 0 temp2 CMP ! is here >= end?
"end" get BLE
%prepare-alien-invoke
"minor_gc" f %alien-invoke
0 3 LI
0 4 LI
"inline_gc" f %alien-invoke
"end" resolve-label ;
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
math namespaces sequences system layouts io vocabs.loader
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.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
! 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-2 EDX ;
M:: x86.32 %dispatch ( src temp offset -- )
M:: x86.32 %dispatch ( src temp -- )
! Load jump table base.
src HEX: ffffffff ADD
offset cells rc-absolute-cell rel-here
0 rc-absolute-cell rel-here
! Go
src HEX: 7f [+] JMP
! Fix up the displacement above
@ -305,10 +306,7 @@ os windows? [
4 "double" c-type (>>align)
] unless
FUNCTION: bool check_sse2 ( ) ;
: sse2? ( -- ? )
check_sse2 ;
USING: cpu.x86.features cpu.x86.features.private ;
"-no-sse2" (command-line) member? [
[ { 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.
USING: accessors arrays kernel math namespaces make sequences
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
compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.intrinsics ;
compiler.cfg.intrinsics compiler.cfg.stack-frame ;
IN: cpu.x86.64
M: x86.64 machine-registers
@ -22,10 +22,10 @@ M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M:: x86.64 %dispatch ( src temp offset -- )
M:: x86.64 %dispatch ( src temp -- )
! Load jump table base.
temp HEX: ffffffff MOV
offset cells rc-absolute-cell rel-here
0 rc-absolute-cell rel-here
! Add jump table base
src temp ADD
src HEX: 7f [+] JMP

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: 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.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io.binary kernel combinators
kernel.private math namespaces make sequences words system layouts
math.order accessors cpu.x86.assembler.syntax ;
USING: arrays io.binary kernel combinators kernel.private math
namespaces make sequences words system layouts math.order accessors
cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler
! 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) ;
: SAR ( dst n -- ) BIN: 111 (SHIFT) ;
GENERIC: IMUL2 ( dst src -- )
M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
: IMUL2 ( dst src -- )
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 -- )
dup register-32? OCT: 143 OCT: 276 extended-opcode ?
over register-16? [ BIN: 1 opcode-or ] when
swapd
swap
over register-32? OCT: 143 OCT: 276 extended-opcode ?
pick register-16? [ BIN: 1 opcode-or ] when
(2-operand) ;
: MOVZX ( dst src -- )
swap
OCT: 266 extended-opcode
over register-16? [ BIN: 1 opcode-or ] when
swapd
pick register-16? [ BIN: 1 opcode-or ] when
(2-operand) ;
! 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
compiler.constants compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.intrinsics
compiler.codegen compiler.codegen.fixup ;
compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup ;
IN: cpu.x86
<< enable-fixnum-log2 >>
@ -17,6 +17,32 @@ M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
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-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-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 ;
: 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 ;
: code-alignment ( align -- n )
[ building get [ integer? ] count dup ] dip align swap - ;
[ building get length dup ] dip align swap - ;
: align-code ( n -- )
0 <repetition> % ;
M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
:: (%slot) ( obj slot tag temp -- op )
temp slot obj [+] LEA
temp tag neg [+] ; inline
@ -99,7 +108,7 @@ M: x86 %add-imm [+] LEA ;
M: x86 %sub nip SUB ;
M: x86 %sub-imm neg [+] LEA ;
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-imm nip AND ;
M: x86 %or nip OR ;
@ -315,17 +324,29 @@ M:: x86 %box-alien ( dst src temp -- )
"end" resolve-label
] with-scope ;
: small-reg-4 ( reg -- reg' )
: small-reg-8 ( reg -- reg' )
H{
{ EAX EAX }
{ ECX ECX }
{ EDX EDX }
{ EBX EBX }
{ ESP ESP }
{ EBP EBP }
{ ESI ESP }
{ EDI EDI }
{ EAX RAX }
{ ECX RCX }
{ EDX RDX }
{ EBX RBX }
{ ESP RSP }
{ EBP RBP }
{ ESI RSP }
{ 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 }
{ RCX ECX }
{ RDX EDX }
@ -361,12 +382,21 @@ M:: x86 %box-alien ( dst src temp -- )
{ 1 [ small-reg-1 ] }
{ 2 [ small-reg-2 ] }
{ 4 [ small-reg-4 ] }
{ 8 [ small-reg-8 ] }
} 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-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 -- )
[ 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
#! register that is not in exclude, and call quot, saving
#! 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
[ quot call ] with-save/restore
] if ; inline
@ -492,29 +522,58 @@ M:: x86 %write-barrier ( src card# table -- )
table table [] MOV
table card# [+] card-mark <byte> MOV ;
M: x86 %gc ( -- )
"end" define-label
temp-reg-1 load-zone-ptr
temp-reg-2 temp-reg-1 cell [+] MOV
temp-reg-2 1024 ADD
temp-reg-1 temp-reg-1 3 cells [+] MOV
temp-reg-2 temp-reg-1 CMP
"end" get JLE
:: check-nursery ( temp1 temp2 -- )
temp1 load-zone-ptr
temp2 temp1 cell [+] MOV
temp2 1024 ADD
temp1 temp1 3 cells [+] MOV
temp2 temp1 CMP ;
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
"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 ;
M: x86 %alien-global
[ 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 ;
:: %boolean ( dst temp word -- )
@ -568,28 +627,6 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
{ cc/= [ JNE ] }
} 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 %reload-integer ( dst n -- ) spill-integer@ MOV ;

13
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 ;
: undefined-symbol-error. ( obj -- )
"The image refers to a library or symbol that was not found"
" at load time" append print drop ;
"The image refers to a library or symbol that was not found at load time"
print drop ;
: stack-underflow. ( obj name -- )
write " stack underflow" print drop ;
@ -252,12 +252,15 @@ M: no-current-vocab summary
drop "Not in a vocabulary; IN: form required" ;
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: 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 ;
@ -317,4 +320,4 @@ M: wrong-values summary drop "Quotation called with wrong stack effect" ;
{
{ [ os windows? ] [ "debugger.windows" require ] }
{ [ os unix? ] [ "debugger.unix" require ] }
} cond
} cond

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

@ -77,6 +77,9 @@ IN: formatting.tests
[ t ] [ "[####monkey]" "monkey" "[%'#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
@ -95,3 +98,4 @@ IN: formatting.tests
[ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" 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 ;
: <ftp-server> ( directory port -- server )
ftp-server new-threaded-server
latin1 ftp-server new-threaded-server
swap >>insecure
swap canonicalize-path >>serving-directory
"ftp.server" >>name
5 minutes >>timeout
latin1 >>encoding ;
5 minutes >>timeout ;
: ftpd ( directory port -- )
<ftp-server> start-server ;

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

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

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

@ -59,4 +59,11 @@ IN: generalizations.tests
{ 3 5 } [ 2 nweave ] must-infer-as
[ { 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 -- )
1- [ dup ] [ '[ _ dip swap ] ] repeat ;
MACRO: nover ( n -- )
dup '[ _ 1 + npick ] n*quot ;
MACRO: ndup ( n -- )
dup '[ _ npick ] n*quot ;
@ -69,6 +72,9 @@ MACRO: ncurry ( n -- )
MACRO: nwith ( n -- )
[ with ] n*quot ;
MACRO: nbi ( n -- )
'[ [ _ nkeep ] dip call ] ;
MACRO: ncleave ( quots n -- )
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
compose ;
@ -91,6 +97,9 @@ MACRO: nweave ( n -- )
[ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
'[ _ _ ncleave ] ;
MACRO: nbi-curry ( n -- )
[ bi-curry ] n*quot ;
: nappend-as ( n exemplar -- seq )
[ 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 ]
produce nip ;
: heap-values ( heap -- alist )
data>> [ value>> ] { } map-as ;
: slurp-heap ( heap quot: ( elt -- ) -- )
over heap-empty? [ 2drop ] [
[ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi

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