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

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

db4
Daniel Ehrenberg 2009-06-01 22:40:19 -05:00
parent 52017e22f3 bbd8651584
commit 1162e337d9
76 changed files with 1367 additions and 655 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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 ;

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

@ -81,30 +81,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 +159,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

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

@ -1,6 +1,7 @@
! 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 make fry sequences ;
IN: compiler.cfg
TUPLE: basic-block < identity-tuple
@ -10,18 +11,27 @@ number
{ 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

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

@ -0,0 +1 @@
Slava Pestov

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

@ -0,0 +1,58 @@
! 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? ]
[ ##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 -- )
[

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

@ -1,28 +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 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: ##unary/temp defs-vregs dst>> 1array ;
M: ##allot defs-vregs dst>> 1array ;
M: ##slot defs-vregs dst>> 1array ;
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: ##string-nth defs-vregs dst>> 1array ;
M: ##compare defs-vregs dst>> 1array ;
M: ##compare-imm defs-vregs dst>> 1array ;
M: ##compare-float defs-vregs dst>> 1array ;
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: _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 +50,14 @@ 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: ##gc uses-vregs live-in>> ;
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 +66,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

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

@ -0,0 +1,22 @@
! 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 ;
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? [
dup
[ swap object-pointer-regs \ ##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 ;

27
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,8 +46,8 @@ 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 } ;
@ -57,13 +59,12 @@ TUPLE: stack-frame
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 +161,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 +182,8 @@ INSN: ##branch ;
INSN: ##loop-entry ;
INSN: ##phi < ##pure inputs ;
! Condition codes
SYMBOL: cc<
SYMBOL: cc<=
@ -217,16 +223,19 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc temp ;
INSN: ##gc live-in ;
! 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 ;

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 ;

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

@ -13,13 +13,13 @@ IN: compiler.cfg.linear-scan.assignment
! 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
TUPLE: active-intervals seq ;
: add-active ( live-interval -- )
active-intervals get push ;
active-intervals get seq>> push ;
: lookup-register ( vreg -- reg )
active-intervals get [ vreg>> = ] with find nip reg>> ;
active-intervals get seq>> [ vreg>> = ] with find nip reg>> ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
@ -41,8 +41,7 @@ SYMBOL: unhandled-intervals
: expire-old-intervals ( n -- )
active-intervals get
swap '[ end>> _ = ] partition
active-intervals set
[ swap '[ end>> _ = ] partition ] change-seq drop
[ insert-spill ] each ;
: insert-reload ( live-interval -- )
@ -59,29 +58,38 @@ SYMBOL: unhandled-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
: all-vregs ( insn -- vregs )
[ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
M: vreg-insn assign-registers-in-insn
active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter
[ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
>>regs drop ;
M: insn (assign-registers) drop ;
M: insn assign-registers-in-insn drop ;
: <active-intervals> ( -- obj )
V{ } clone active-intervals boa ;
: init-assignment ( live-intervals -- )
V{ } clone active-intervals set
<active-intervals> active-intervals set
<min-heap> unhandled-intervals 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#>> activate-new-intervals ]
[ [ assign-registers-in-insn ] [ , ] bi ]
[ insn#>> expire-old-intervals ]
tri
] each
] V{ } make
] change-instructions drop ;
: assign-registers ( rpo live-intervals -- )
init-assignment
[ assign-registers-in-block ] each ;

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

@ -3,6 +3,8 @@ USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors
math.order grouping
cpu.architecture
compiler.cfg
compiler.cfg.optimizer
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.linear-scan
@ -264,18 +266,27 @@ SYMBOL: max-uses
USING: math.private compiler.cfg.debugger ;
[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
[ ] [
[ float+ float>fixnum 3 fixnum*fast ]
test-cfg first optimize-cfg 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?
T{ basic-block
{ instructions
V{
T{ ##allot
f
T{ vreg f int-regs 1 }
40
array
T{ vreg f int-regs 2 }
f
}
}
}
} clone [ [ clone ] map ] change-instructions
dup 1array (linear-scan) instructions>> first regs>> values all-equal?
] unit-test
[ 0 1 ] [

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

@ -1,9 +1,11 @@
! 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.assignment ;
@ -23,16 +25,13 @@ 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' )
: (linear-scan) ( rpo -- )
dup number-instructions
dup compute-live-intervals
machine-registers allocate-registers assign-registers ;
: linear-scan ( mr -- mr' )
: linear-scan ( cfg -- cfg' )
[
[
[
(linear-scan) %
spill-counts get _spill-counts
] { } make
] change-instructions
dup reverse-post-order (linear-scan)
spill-counts get >>spill-counts
] with-scope ;

18
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.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: namespaces kernel assocs accessors sequences math fry
compiler.cfg.instructions compiler.cfg.registers
@ -38,27 +38,29 @@ SYMBOL: live-intervals
[ [ <live-interval> ] keep ] dip set-at
] if ;
GENERIC# compute-live-intervals* 1 ( insn n -- )
GENERIC: compute-live-intervals* ( insn -- )
M: insn compute-live-intervals* 2drop ;
M: insn compute-live-intervals* drop ;
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 ;
[ [ temp-vregs ] 2dip '[ _ swap _ new-live-interval ] 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 )
: compute-live-intervals ( rpo -- live-intervals )
H{ } clone [
live-intervals set
[ compute-live-intervals* ] each-index
[ instructions>> [ compute-live-intervals* ] each ] each
] keep values ;

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 ;

60
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
cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.liveness
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,31 @@ 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 ;
: linearize-basic-blocks ( cfg -- insns )
[
[ [ linearize-basic-block ] each-basic-block ]
[ spill-counts>> _spill-counts ]
bi
] { } make ;
: linearize-basic-blocks ( rpo -- insns )
[ [ linearize-basic-block ] each ] { } make ;
: build-mr ( cfg -- mr )
[ entry>> reverse-post-order linearize-basic-blocks ]
[ word>> ] [ label>> ]
tri <mr> ;
: 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.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

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

@ -1,29 +1,30 @@
! 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 ;
IN: compiler.cfg.optimizer
: trivial? ( insns -- ? )
dup length 2 = [ first ##call? ] [ drop f ] if ;
: 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
] 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 ;

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

@ -1,10 +1,10 @@
! 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 ;
dup [ predecessors-step ] each-basic-block ;

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

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

@ -0,0 +1,113 @@
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 ;
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>> ;
[ ] [ [ ] 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 ;

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

@ -32,8 +32,8 @@ M: insn compute-stack-frame*
frame-required? on
] when ;
\ _gc t frame-required? set-word-prop
\ _spill t frame-required? set-word-prop
\ ##gc 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

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

@ -1,7 +1,7 @@
! 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 arrays kernel sequences make compiler.cfg.instructions
compiler.cfg.rpo cpu.architecture ;
IN: compiler.cfg.two-operand
! On x86, instructions take the form x = x op y
@ -11,26 +11,26 @@ IN: compiler.cfg.two-operand
! has a LEA instruction which is effectively a three-operand
! addition
: 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 ;
@ -50,11 +50,13 @@ 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? [
dup [
[
[ [ convert-two-operand* ] each ] V{ } make
] change-instructions drop
] each-basic-block
] 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

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

@ -26,14 +26,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 +43,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 +89,11 @@ 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 %dispatch-label ;
: >slot< ( insn -- dst obj slot tag )
{
@ -236,7 +234,7 @@ M: ##write-barrier generate-insn
[ table>> register ]
tri %write-barrier ;
M: _gc generate-insn drop %gc ;
M: ##gc generate-insn drop %gc ;
M: ##loop-entry generate-insn drop %loop-entry ;
@ -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 ;

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

40
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 ;

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 ;

11
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
@ -51,8 +44,8 @@ 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: %dispatch-label cpu ( label -- )
HOOK: %slot cpu ( dst obj slot tag temp -- )
HOOK: %slot-imm cpu ( dst obj slot tag -- )

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

@ -124,16 +124,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

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

@ -26,10 +26,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

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

@ -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

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

@ -74,13 +74,13 @@ 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 ;
M: x86 %dispatch-label ( label -- )
0 cell, rc-absolute-cell label-fixup ;
:: (%slot) ( obj slot tag temp -- op )
temp slot obj [+] LEA

4
core/assocs/assocs-tests.factor
View File

@ -130,3 +130,7 @@ unit-test
[ 1 f ] [ 1 H{ } ?at ] unit-test
[ 2 t ] [ 1 H{ { 1 2 } } ?at ] unit-test
[ f ] [ 1 2 H{ { 2 1 } } maybe-set-at ] unit-test
[ t ] [ 1 3 H{ { 2 1 } } clone maybe-set-at ] unit-test
[ t ] [ 3 2 H{ { 2 1 } } clone maybe-set-at ] unit-test

3
core/assocs/assocs.factor
View File

@ -22,6 +22,9 @@ M: assoc assoc-like drop ;
: ?at ( key assoc -- value/key ? )
2dup at* [ 2nip t ] [ 2drop f ] if ; inline
: maybe-set-at ( value key assoc -- changed? )
3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ;
<PRIVATE
: (assoc-each) ( assoc quot -- seq quot' )

56
extra/cursors/cursors.factor
View File

@ -12,31 +12,32 @@ GENERIC: cursor-write ( obj cursor -- )
ERROR: cursor-ended cursor ;
: cursor-get ( cursor -- obj )
dup cursor-done?
[ cursor-ended ] [ cursor-get-unsafe ] if ; inline
dup cursor-done?
[ cursor-ended ] [ cursor-get-unsafe ] if ; inline
: find-done? ( quot cursor -- ? )
dup cursor-done? [ 2drop t ] [ cursor-get-unsafe swap call ] if ; inline
: cursor-until ( quot cursor -- )
[ find-done? not ]
[ cursor-advance drop ] bi-curry bi-curry while ; inline
: find-done? ( cursor quot -- ? )
over cursor-done?
[ 2drop t ] [ [ cursor-get-unsafe ] dip call ] if ; inline
: cursor-until ( cursor quot -- )
[ find-done? not ]
[ drop cursor-advance ] bi-curry bi-curry while ; inline
: cursor-each ( cursor quot -- )
[ f ] compose swap cursor-until ; inline
[ f ] compose cursor-until ; inline
: cursor-find ( cursor quot -- obj ? )
swap [ cursor-until ] keep
dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
[ cursor-until ] [ drop ] 2bi
dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
: cursor-any? ( cursor quot -- ? )
cursor-find nip ; inline
cursor-find nip ; inline
: cursor-all? ( cursor quot -- ? )
[ not ] compose cursor-any? not ; inline
[ not ] compose cursor-any? not ; inline
: cursor-map-quot ( quot to -- quot' )
[ [ call ] dip cursor-write ] 2curry ; inline
[ [ call ] dip cursor-write ] 2curry ; inline
: cursor-map ( from to quot -- )
swap cursor-map-quot cursor-each ; inline
@ -46,10 +47,10 @@ ERROR: cursor-ended cursor ;
[ cursor-write ] 2curry when ; inline
: cursor-filter-quot ( quot to -- quot' )
[ cursor-write-if ] 2curry ; inline
[ cursor-write-if ] 2curry ; inline
: cursor-filter ( from to quot -- )
swap cursor-filter-quot cursor-each ; inline
swap cursor-filter-quot cursor-each ; inline
TUPLE: from-sequence { seq sequence } { n integer } ;
@ -60,19 +61,19 @@ M: from-sequence cursor-done? ( cursor -- ? )
>from-sequence< length >= ;
M: from-sequence cursor-valid?
>from-sequence< bounds-check? not ;
>from-sequence< bounds-check? not ;
M: from-sequence cursor-get-unsafe
>from-sequence< nth-unsafe ;
>from-sequence< nth-unsafe ;
M: from-sequence cursor-advance
[ 1+ ] change-n drop ;
[ 1+ ] change-n drop ;
: >input ( seq -- cursor )
0 from-sequence boa ; inline
0 from-sequence boa ; inline
: iterate ( seq quot iterator -- )
[ >input ] 2dip call ; inline
[ >input ] 2dip call ; inline
: each ( seq quot -- ) [ cursor-each ] iterate ; inline
: find ( seq quot -- ? ) [ cursor-find ] iterate ; inline
@ -82,18 +83,19 @@ M: from-sequence cursor-advance
TUPLE: to-sequence { seq sequence } { exemplar sequence } ;
M: to-sequence cursor-write
seq>> push ;
seq>> push ;
: freeze ( cursor -- seq )
[ seq>> ] [ exemplar>> ] bi like ; inline
[ seq>> ] [ exemplar>> ] bi like ; inline
: >output ( seq -- cursor )
[ [ length ] keep new-resizable ] keep
to-sequence boa ; inline
[ [ length ] keep new-resizable ] keep
to-sequence boa ; inline
: transform ( seq quot transformer -- newseq )
[ [ >input ] [ >output ] bi ] 2dip
[ call ] [ 2drop freeze ] 3bi ; inline
[ [ >input ] [ >output ] bi ] 2dip
[ call ]
[ 2drop freeze ] 3bi ; inline
: map ( seq quot -- ) [ cursor-map ] transform ; inline
: filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline

10
extra/fuel/fuel.factor
View File

@ -134,14 +134,16 @@ PRIVATE>
! Scaffold support
: fuel-scaffold-name ( devname -- )
[ developer-name set ] when* ;
: fuel-scaffold-vocab ( root name devname -- )
developer-name set dup [ scaffold-vocab ] dip
[ fuel-scaffold-name dup [ scaffold-vocab ] dip ] with-scope
dup require vocab-source-path (normalize-path) fuel-eval-set-result ;
: fuel-scaffold-help ( name devname -- )
developer-name set
dup require dup scaffold-help vocab-docs-path
(normalize-path) fuel-eval-set-result ;
[ fuel-scaffold-name dup require dup scaffold-help ] with-scope
vocab-docs-path (normalize-path) fuel-eval-set-result ;
: fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;

12
extra/irc/client/internals/internals-tests.factor
View File

@ -85,6 +85,18 @@ M: mb-writer dispose drop ;
] with-irc
] unit-test
! Test connect with password
{ V{ "PASS password" "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
"someserver" irc-port "factorbot" "password" <irc-profile> <irc-client>
[ 2drop <test-stream> ] >>connect
[
(connect-irc)
(do-login)
irc> stream>> out>> lines>>
(terminate-irc)
] with-irc
] unit-test
! Test join
[ { "JOIN #factortest" } [
"#factortest" %join %pop-output-line

7
extra/irc/client/internals/internals.factor
View File

@ -16,6 +16,7 @@ IN: irc.client.internals
: /NICK ( nick -- ) "NICK " prepend irc-print ;
: /PONG ( text -- ) "PONG " prepend irc-print ;
: /PASS ( password -- ) "PASS " prepend irc-print ;
: /LOGIN ( nick -- )
dup /NICK
@ -44,7 +45,11 @@ IN: irc.client.internals
in-messages>> [ irc-connected ] dip mailbox-put
] [ (terminate-irc) ] if* ;
: (do-login) ( -- ) irc> nick>> /LOGIN ;
: (do-login) ( -- )
irc>
[ profile>> password>> [ /PASS ] when* ]
[ nick>> /LOGIN ]
bi ;
GENERIC: initialize-chat ( chat -- )
M: irc-chat initialize-chat drop ;

21
extra/managed-server/chat/chat.factor
View File

@ -18,6 +18,9 @@ chat-docs [ H{ } clone ] initialize
CONSTANT: line-beginning "-!- "
: send-line ( string -- )
write "\r\n" write flush ;
: handle-me ( string -- )
[
[ "* " username " " ] dip
@ -29,15 +32,15 @@ CONSTANT: line-beginning "-!- "
: handle-help ( string -- )
[
"Commands: "
commands get keys natural-sort ", " join append print flush
commands get keys natural-sort ", " join append send-line
] [
chat-docs get ?at
[ print flush ]
[ "Unknown command: " prepend print flush ] if
[ send-line ]
[ "Unknown command: " prepend send-line ] if
] if-empty ;
: usage ( string -- )
chat-docs get at print flush ;
chat-docs get at send-line ;
: username-taken-string ( username -- string )
"The username ``" "'' is already in use; try again." surround ;
@ -53,7 +56,7 @@ CONSTANT: line-beginning "-!- "
"nick" usage
] [
dup clients key? [
username-taken-string print flush
username-taken-string send-line
] [
[ username swap warn-name-changed ]
[ username clients rename-at ]
@ -70,12 +73,12 @@ CONSTANT: line-beginning "-!- "
Displays the documentation for a command.">
"help" add-command
[ drop clients keys [ "``" "''" surround ] map ", " join print flush ]
[ drop clients keys [ "``" "''" surround ] map ", " join send-line ]
<" Syntax: /who
Shows the list of connected users.">
"who" add-command
[ drop gmt timestamp>rfc822 print flush ]
[ drop gmt timestamp>rfc822 send-line ]
<" Syntax: /time
Returns the current GMT time."> "time" add-command
@ -96,7 +99,7 @@ Disconnects a user from the chat server."> "quit" add-command
dup " " split1 swap >lower commands get at* [
call( string -- ) drop
] [
2drop "Unknown command: " prepend print flush
2drop "Unknown command: " prepend send-line
] if ;
: <chat-server> ( port -- managed-server )
@ -123,7 +126,7 @@ M: chat-server handle-client-disconnect
] "" append-outputs-as send-everyone ;
M: chat-server handle-already-logged-in
username username-taken-string print flush ;
username username-taken-string send-line ;
M: chat-server handle-managed-client*
readln dup f = [ t client (>>quit?) ] when

5
misc/fuel/fuel-scaffold.el
View File

@ -26,9 +26,10 @@
"Options for FUEL's scaffolding."
:group 'fuel)
(defcustom fuel-scaffold-developer-name user-full-name
(defcustom fuel-scaffold-developer-name nil
"The name to be inserted as yours in scaffold templates."
:type 'string
:type '(choice string
(const :tag "Factor's value for developer-name" nil))
:group 'fuel-scaffold)

5
misc/fuel/fuel-syntax.el
View File

@ -59,7 +59,7 @@
"POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
"QUALIFIED-WITH:" "QUALIFIED:"
"read-only" "RENAME:" "REQUIRE:" "REQUIRES:"
"SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:"
"SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"
"TUPLE:" "t" "t?" "TYPEDEF:"
"UNION:" "USE:" "USING:"
"VARS:"))
@ -109,7 +109,7 @@
(format "\\_<\\(%s\\)?: +\\_<\\(\\w+\\)\\_>"
(regexp-opt
'(":" "GENERIC" "DEFER" "HOOK" "MAIN" "MATH" "POSTPONE"
"SYMBOL" "RENAME"))))
"SYMBOL" "SYNTAX" "RENAME"))))
(defconst fuel-syntax--alias-definition-regex
"^ALIAS: +\\(\\_<.+?\\_>\\) +\\(\\_<.+?\\_>\\)")
@ -156,6 +156,7 @@
"INTERSECTION:"
"M" "MACRO" "MACRO:"
"MEMO" "MEMO:" "METHOD"
"SYNTAX"
"PREDICATE" "PRIMITIVE"
"UNION"))

5
vm/code_block.cpp
View File

@ -159,7 +159,10 @@ cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
case RT_XT_PIC_TAIL:
return (cell)word_xt_pic_tail(untag<word>(ARG));
case RT_HERE:
return offset + (short)untag_fixnum(ARG);
{
fixnum arg = untag_fixnum(ARG);
return (arg >= 0 ? offset + arg : (cell)(compiled +1) - arg);
}
case RT_THIS:
return (cell)(compiled + 1);
case RT_STACK_CHAIN: