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

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

db4
John Benediktsson 2009-06-01 12:45:30 -07:00
parent d99ae5af92 a4a2ae8a78
commit 938f33c786
99 changed files with 1762 additions and 676 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 IN: compiler.cfg.alias-analysis.tests
[ ] [
{
T{ ##peek f V int-regs 2 D 1 f }
T{ ##box-alien f V int-regs 1 V int-regs 2 }
T{ ##slot-imm f V int-regs 3 V int-regs 1 0 3 }
} alias-analysis drop
] unit-test
[ ] [
{
T{ ##load-reference f V int-regs 1 "hello" }
T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
} alias-analysis drop
] unit-test
[
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 2 f }
T{ ##replace f V int-regs 1 D 0 f }
}
] [
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 2 f }
T{ ##replace f V int-regs 2 D 0 f }
T{ ##replace f V int-regs 1 D 0 f }
} alias-analysis
] unit-test
[
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 0 f }
T{ ##copy f V int-regs 3 V int-regs 2 f }
T{ ##copy f V int-regs 4 V int-regs 1 f }
T{ ##replace f V int-regs 3 D 0 f }
T{ ##replace f V int-regs 4 D 1 f }
}
] [
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 0 f }
T{ ##replace f V int-regs 1 D 0 f }
T{ ##replace f V int-regs 2 D 1 f }
T{ ##peek f V int-regs 3 D 1 f }
T{ ##peek f V int-regs 4 D 0 f }
T{ ##replace f V int-regs 3 D 0 f }
T{ ##replace f V int-regs 4 D 1 f }
} alias-analysis
] unit-test

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

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

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

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

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

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 SYMBOL: copies
: resolve ( vreg -- vreg ) : resolve ( vreg -- vreg )
dup copies get at swap or ; [ copies get at ] keep or ;
: record-copy ( insn -- ) : record-copy ( insn -- )
[ src>> resolve ] [ dst>> ] bi copies get set-at ; inline [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline

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

@ -0,0 +1 @@
Slava Pestov

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

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

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

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

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

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

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

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

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

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

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

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

@ -0,0 +1 @@
Slava Pestov

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

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

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

@ -0,0 +1 @@
Slava Pestov

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 : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline

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

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

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. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors arrays kernel sequences namespaces words USING: assocs accessors arrays kernel sequences namespaces words
math math.order layouts classes.algebra alien byte-arrays math math.order layouts classes.algebra alien byte-arrays
@ -6,6 +6,8 @@ compiler.constants combinators compiler.cfg.registers
compiler.cfg.instructions.syntax ; compiler.cfg.instructions.syntax ;
IN: compiler.cfg.instructions IN: compiler.cfg.instructions
: new-insn ( ... class -- insn ) [ f f ] dip boa ; inline
! Virtual CPU instructions, used by CFG and machine IRs ! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: insn ; TUPLE: insn ;
@ -44,8 +46,8 @@ M: fixnum ##load-literal tag-fixnum ##load-immediate ;
M: f ##load-literal drop \ f tag-number ##load-immediate ; M: f ##load-literal drop \ f tag-number ##load-immediate ;
M: object ##load-literal ##load-reference ; M: object ##load-literal ##load-reference ;
INSN: ##peek < ##read { loc loc } ; INSN: ##peek < ##flushable { loc loc } ;
INSN: ##replace < ##write { loc loc } ; INSN: ##replace < ##effect { loc loc } ;
INSN: ##inc-d { n integer } ; INSN: ##inc-d { n integer } ;
INSN: ##inc-r { n integer } ; INSN: ##inc-r { n integer } ;
@ -57,13 +59,12 @@ TUPLE: stack-frame
spill-counts ; spill-counts ;
INSN: ##stack-frame stack-frame ; INSN: ##stack-frame stack-frame ;
INSN: ##call word ; INSN: ##call word { height integer } ;
INSN: ##jump word ; INSN: ##jump word ;
INSN: ##return ; INSN: ##return ;
! Jump tables ! Jump tables
INSN: ##dispatch src temp offset ; INSN: ##dispatch src temp ;
INSN: ##dispatch-label label ;
! Slot access ! Slot access
INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ; INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
@ -160,9 +161,12 @@ INSN: ##set-alien-double < ##alien-setter ;
! Memory allocation ! Memory allocation
INSN: ##allot < ##flushable size class { temp vreg } ; INSN: ##allot < ##flushable size class { temp vreg } ;
UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
INSN: ##write-barrier < ##effect card# table ; INSN: ##write-barrier < ##effect card# table ;
INSN: ##alien-global < ##read symbol library ; INSN: ##alien-global < ##flushable symbol library ;
! FFI ! FFI
INSN: ##alien-invoke params ; INSN: ##alien-invoke params ;
@ -178,6 +182,8 @@ INSN: ##branch ;
INSN: ##loop-entry ; INSN: ##loop-entry ;
INSN: ##phi < ##pure inputs ;
! Condition codes ! Condition codes
SYMBOL: cc< SYMBOL: cc<
SYMBOL: cc<= SYMBOL: cc<=
@ -217,16 +223,19 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
INSN: ##compare-float-branch < ##conditional-branch ; INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc temp ; INSN: ##compare-float < ##binary cc temp ;
INSN: ##gc live-in ;
! Instructions used by machine IR only. ! Instructions used by machine IR only.
INSN: _prologue stack-frame ; INSN: _prologue stack-frame ;
INSN: _epilogue stack-frame ; INSN: _epilogue stack-frame ;
INSN: _label id ; INSN: _label id ;
INSN: _gc ;
INSN: _branch label ; INSN: _branch label ;
INSN: _dispatch src temp ;
INSN: _dispatch-label label ;
TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ; TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
INSN: _compare-branch < _conditional-branch ; INSN: _compare-branch < _conditional-branch ;

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

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

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

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

46
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 ! 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 ! 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. ! time anyway, it is not a problem to check each element.
SYMBOL: active-intervals TUPLE: active-intervals seq ;
: add-active ( live-interval -- ) : add-active ( live-interval -- )
active-intervals get push ; active-intervals get seq>> push ;
: lookup-register ( vreg -- reg ) : 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 ! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals SYMBOL: unhandled-intervals
@ -41,8 +41,7 @@ SYMBOL: unhandled-intervals
: expire-old-intervals ( n -- ) : expire-old-intervals ( n -- )
active-intervals get active-intervals get
swap '[ end>> _ = ] partition [ swap '[ end>> _ = ] partition ] change-seq drop
active-intervals set
[ insert-spill ] each ; [ insert-spill ] each ;
: insert-reload ( live-interval -- ) : insert-reload ( live-interval -- )
@ -59,29 +58,38 @@ SYMBOL: unhandled-intervals
] [ 2drop ] if ] [ 2drop ] if
] if ; ] if ;
GENERIC: (assign-registers) ( insn -- ) GENERIC: assign-registers-in-insn ( insn -- )
M: vreg-insn (assign-registers) : all-vregs ( insn -- vregs )
dup [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
[ defs-vregs ] [ uses-vregs ] bi append
active-intervals get swap '[ vreg>> _ member? ] filter M: vreg-insn assign-registers-in-insn
active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter
[ [ vreg>> ] [ reg>> ] bi ] { } map>assoc [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
>>regs drop ; >>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 -- ) : init-assignment ( live-intervals -- )
V{ } clone active-intervals set <active-intervals> active-intervals set
<min-heap> unhandled-intervals set <min-heap> unhandled-intervals set
init-unhandled ; init-unhandled ;
: assign-registers ( insns live-intervals -- insns' ) : assign-registers-in-block ( bb -- )
[ [
init-assignment
[ [
[ activate-new-intervals ] [
[ drop [ (assign-registers) ] [ , ] bi ] [ insn#>> activate-new-intervals ]
[ expire-old-intervals ] [ [ assign-registers-in-insn ] [ , ] bi ]
[ insn#>> expire-old-intervals ]
tri tri
] each-index ] each
] { } make ; ] V{ } make
] change-instructions drop ;
: assign-registers ( rpo live-intervals -- )
init-assignment
[ assign-registers-in-block ] each ;

17
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 kernel fry arrays splitting namespaces math accessors vectors
math.order grouping math.order grouping
cpu.architecture cpu.architecture
compiler.cfg
compiler.cfg.optimizer
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.linear-scan compiler.cfg.linear-scan
@ -264,9 +266,15 @@ SYMBOL: max-uses
USING: math.private compiler.cfg.debugger ; USING: math.private compiler.cfg.debugger ;
[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test [ ] [
[ float+ float>fixnum 3 fixnum*fast ]
test-cfg first optimize-cfg linear-scan drop
] unit-test
[ f ] [ [ f ] [
T{ basic-block
{ instructions
V{
T{ ##allot T{ ##allot
f f
T{ vreg f int-regs 1 } T{ vreg f int-regs 1 }
@ -274,8 +282,11 @@ USING: math.private compiler.cfg.debugger ;
array array
T{ vreg f int-regs 2 } T{ vreg f int-regs 2 }
f f
} clone }
1array (linear-scan) first regs>> values all-equal? }
}
} clone [ [ clone ] map ] change-instructions
dup 1array (linear-scan) instructions>> first regs>> values all-equal?
] unit-test ] unit-test
[ 0 1 ] [ [ 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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make USING: kernel accessors namespaces make
cpu.architecture cpu.architecture
compiler.cfg compiler.cfg
compiler.cfg.rpo
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.assignment ; compiler.cfg.linear-scan.assignment ;
@ -23,16 +25,13 @@ IN: compiler.cfg.linear-scan
! by Omri Traub, Glenn Holloway, Michael D. Smith ! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
: (linear-scan) ( insns -- insns' ) : (linear-scan) ( rpo -- )
dup number-instructions
dup compute-live-intervals dup compute-live-intervals
machine-registers allocate-registers assign-registers ; machine-registers allocate-registers assign-registers ;
: linear-scan ( mr -- mr' ) : linear-scan ( cfg -- cfg' )
[ [
[ dup reverse-post-order (linear-scan)
[ spill-counts get >>spill-counts
(linear-scan) %
spill-counts get _spill-counts
] { } make
] change-instructions
] with-scope ; ] 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. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math fry USING: namespaces kernel assocs accessors sequences math fry
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.instructions compiler.cfg.registers
@ -38,27 +38,29 @@ SYMBOL: live-intervals
[ [ <live-interval> ] keep ] dip set-at [ [ <live-interval> ] keep ] dip set-at
] if ; ] 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* M: vreg-insn compute-live-intervals*
dup insn#>>
live-intervals get live-intervals get
[ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ] [ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
[ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ] [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
3bi ; [ [ temp-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
3tri ;
: record-copy ( insn -- ) : record-copy ( insn -- )
[ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ; [ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
M: ##copy compute-live-intervals* M: ##copy compute-live-intervals*
[ call-next-method ] [ drop record-copy ] 2bi ; [ call-next-method ] [ record-copy ] bi ;
M: ##copy-float compute-live-intervals* M: ##copy-float compute-live-intervals*
[ call-next-method ] [ drop record-copy ] 2bi ; [ call-next-method ] [ record-copy ] bi ;
: compute-live-intervals ( instructions -- live-intervals ) : compute-live-intervals ( rpo -- live-intervals )
H{ } clone [ H{ } clone [
live-intervals set live-intervals set
[ compute-live-intervals* ] each-index [ instructions>> [ compute-live-intervals* ] each ] each
] keep values ; ] 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 ;

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

@ -1,17 +1,21 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences namespaces make USING: kernel math accessors sequences namespaces make
combinators classes combinators assocs
cpu.architecture
compiler.cfg compiler.cfg
compiler.cfg.rpo compiler.cfg.rpo
compiler.cfg.liveness
compiler.cfg.instructions ; compiler.cfg.instructions ;
IN: compiler.cfg.linearization IN: compiler.cfg.linearization
! Convert CFG IR to machine IR. ! Convert CFG IR to machine IR.
GENERIC: linearize-insn ( basic-block insn -- ) GENERIC: linearize-insn ( basic-block insn -- )
: linearize-insns ( basic-block -- ) : linearize-basic-block ( bb -- )
dup instructions>> [ linearize-insn ] with each ; inline [ number>> _label ]
[ dup instructions>> [ linearize-insn ] with each ]
bi ;
M: insn linearize-insn , drop ; M: insn linearize-insn , drop ;
@ -30,7 +34,7 @@ M: insn linearize-insn , drop ;
: emit-branch ( basic-block successor -- ) : emit-branch ( basic-block successor -- )
{ {
{ [ 2dup useless-branch? ] [ 2drop ] } { [ 2dup useless-branch? ] [ 2drop ] }
{ [ dup branch-to-branch? ] [ nip linearize-insns ] } { [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
[ nip number>> _branch ] [ nip number>> _branch ]
} cond ; } cond ;
@ -46,35 +50,31 @@ M: ##branch linearize-insn
[ drop dup successors>> second useless-branch? ] 2bi [ drop dup successors>> second useless-branch? ] 2bi
[ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ; [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
: with-regs ( insn quot -- )
over regs>> [ call ] dip building get last (>>regs) ; inline
M: ##compare-branch linearize-insn M: ##compare-branch linearize-insn
binary-conditional _compare-branch emit-branch ; [ binary-conditional _compare-branch ] with-regs emit-branch ;
M: ##compare-imm-branch linearize-insn M: ##compare-imm-branch linearize-insn
binary-conditional _compare-imm-branch emit-branch ; [ binary-conditional _compare-imm-branch ] with-regs emit-branch ;
M: ##compare-float-branch linearize-insn M: ##compare-float-branch linearize-insn
binary-conditional _compare-float-branch emit-branch ; [ binary-conditional _compare-float-branch ] with-regs emit-branch ;
: gc? ( bb -- ? ) M: ##dispatch linearize-insn
instructions>> [ swap
class { [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
##allot [ successors>> [ number>> _dispatch-label ] each ]
##integer>bignum bi* ;
##box-float
##box-alien
} memq?
] any? ;
: linearize-basic-block ( bb -- ) : linearize-basic-blocks ( cfg -- insns )
[ number>> _label ] [
[ gc? [ _gc ] when ] [ [ linearize-basic-block ] each-basic-block ]
[ linearize-insns ] [ spill-counts>> _spill-counts ]
tri ; bi
] { } make ;
: linearize-basic-blocks ( rpo -- insns ) : flatten-cfg ( cfg -- mr )
[ [ linearize-basic-block ] each ] { } make ; [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
<mr> ;
: build-mr ( cfg -- mr )
[ entry>> reverse-post-order 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

25
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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences compiler.cfg.rpo USING: kernel sequences accessors combinators namespaces
compiler.cfg.instructions
compiler.cfg.predecessors compiler.cfg.predecessors
compiler.cfg.useless-blocks compiler.cfg.useless-blocks
compiler.cfg.height compiler.cfg.height
compiler.cfg.stack-analysis
compiler.cfg.alias-analysis compiler.cfg.alias-analysis
compiler.cfg.value-numbering compiler.cfg.value-numbering
compiler.cfg.dead-code compiler.cfg.dce
compiler.cfg.write-barrier ; compiler.cfg.write-barrier
compiler.cfg.liveness
compiler.cfg.rpo
compiler.cfg.phi-elimination ;
IN: compiler.cfg.optimizer IN: compiler.cfg.optimizer
: trivial? ( insns -- ? )
dup length 2 = [ first ##call? ] [ drop f ] if ;
: optimize-cfg ( cfg -- cfg' ) : optimize-cfg ( cfg -- cfg' )
[
compute-predecessors compute-predecessors
delete-useless-blocks delete-useless-blocks
delete-useless-conditionals delete-useless-conditionals
[
dup trivial? [
normalize-height normalize-height
stack-analysis
compute-liveness
alias-analysis alias-analysis
value-numbering value-numbering
eliminate-dead-code eliminate-dead-code
eliminate-write-barriers eliminate-write-barriers
] unless eliminate-phis
] change-basic-blocks ; ] 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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences compiler.cfg.rpo ; USING: kernel accessors sequences compiler.cfg.rpo ;
IN: compiler.cfg.predecessors IN: compiler.cfg.predecessors
: (compute-predecessors) ( bb -- ) : predecessors-step ( bb -- )
dup successors>> [ predecessors>> push ] with each ; dup successors>> [ predecessors>> push ] with each ;
: compute-predecessors ( cfg -- cfg' ) : compute-predecessors ( cfg -- cfg' )
dup [ (compute-predecessors) ] each-basic-block ; 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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make math sequences sets USING: kernel accessors namespaces make math sequences sets
assocs fry compiler.cfg compiler.cfg.instructions ; assocs fry compiler.cfg compiler.cfg.instructions ;
@ -7,29 +7,29 @@ IN: compiler.cfg.rpo
SYMBOL: visited SYMBOL: visited
: post-order-traversal ( bb -- ) : post-order-traversal ( bb -- )
dup id>> visited get key? [ drop ] [ dup visited get key? [ drop ] [
dup id>> visited get conjoin dup visited get conjoin
[ [
successors>> <reversed> successors>> <reversed>
[ post-order-traversal ] each [ post-order-traversal ] each
] [ , ] bi ] [ , ] bi
] if ; ] if ;
: post-order ( bb -- blocks )
[ post-order-traversal ] { } make ;
: number-blocks ( blocks -- ) : number-blocks ( blocks -- )
[ >>number drop ] each-index ; dup length iota <reversed>
[ >>number drop ] 2each ;
: reverse-post-order ( bb -- blocks ) : post-order ( cfg -- blocks )
H{ } clone visited [ dup post-order>> [ ] [
post-order <reversed> dup number-blocks [
] with-variable ; inline H{ } clone visited set
dup entry>> post-order-traversal
] { } make dup number-blocks
>>post-order post-order>>
] ?if ;
: reverse-post-order ( cfg -- blocks )
post-order <reversed> ; inline
: each-basic-block ( cfg quot -- ) : each-basic-block ( cfg quot -- )
[ entry>> reverse-post-order ] dip each ; inline [ reverse-post-order ] dip each ; inline
: change-basic-blocks ( cfg quot -- cfg' )
[ '[ _ change-instructions drop ] each-basic-block ]
[ drop ]
2bi ; inline

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

@ -0,0 +1 @@
Slava Pestov

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 frame-required? on
] when ; ] when ;
\ _gc t frame-required? set-word-prop
\ _spill 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-add t frame-required? set-word-prop
\ ##fixnum-sub t frame-required? set-word-prop \ ##fixnum-sub t frame-required? set-word-prop
\ ##fixnum-mul t frame-required? set-word-prop \ ##fixnum-mul t frame-required? set-word-prop

48
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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel sequences compiler.utilities USING: accessors arrays kernel sequences make compiler.cfg.instructions
compiler.cfg.instructions cpu.architecture ; compiler.cfg.rpo cpu.architecture ;
IN: compiler.cfg.two-operand IN: compiler.cfg.two-operand
! On x86, instructions take the form x = x op y ! On x86, instructions take the form x = x op y
@ -11,26 +11,26 @@ IN: compiler.cfg.two-operand
! has a LEA instruction which is effectively a three-operand ! has a LEA instruction which is effectively a three-operand
! addition ! 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 ) : convert-two-operand/integer ( insn -- )
[ [ dst>> ] [ src1>> ] bi make-copy ] [ [ dst>> ] [ src1>> ] bi ##copy ]
[ dup dst>> >>src1 ] [ dup dst>> >>src1 , ]
bi 2array ; inline bi ; inline
: convert-two-operand/float ( insn -- insns ) : convert-two-operand/float ( insn -- )
[ [ dst>> ] [ src1>> ] bi make-copy/float ] [ [ dst>> ] [ src1>> ] bi ##copy-float ]
[ dup dst>> >>src1 ] [ dup dst>> >>src1 , ]
bi 2array ; inline bi ; inline
GENERIC: convert-two-operand* ( insn -- insns ) GENERIC: convert-two-operand* ( insn -- )
M: ##not convert-two-operand* M: ##not convert-two-operand*
[ [ dst>> ] [ src>> ] bi make-copy ] [ [ dst>> ] [ src>> ] bi ##copy ]
[ dup dst>> >>src ] [ dup dst>> >>src , ]
bi 2array ; bi ;
M: ##sub convert-two-operand* convert-two-operand/integer ; M: ##sub convert-two-operand* convert-two-operand/integer ;
M: ##mul convert-two-operand* convert-two-operand/integer ; M: ##mul convert-two-operand* convert-two-operand/integer ;
@ -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: ##mul-float convert-two-operand* convert-two-operand/float ;
M: ##div-float convert-two-operand* convert-two-operand/float ; M: ##div-float convert-two-operand* convert-two-operand/float ;
M: insn convert-two-operand* ; M: insn convert-two-operand* , ;
: convert-two-operand ( mr -- mr' ) : convert-two-operand ( cfg -- cfg' )
[
two-operand? [ two-operand? [
[ convert-two-operand* ] map-flat dup [
] when [
] change-instructions ; [ [ 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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences combinators classes vectors USING: kernel accessors sequences combinators combinators.short-circuit
compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ; classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.useless-blocks IN: compiler.cfg.useless-blocks
: update-predecessor-for-delete ( bb -- ) : update-predecessor-for-delete ( bb -- )
! We have to replace occurrences of bb with bb's successor
! in bb's predecessor's list of successors.
dup predecessors>> first [ dup predecessors>> first [
[ [
2dup eq? [ drop successors>> first ] [ nip ] if 2dup eq? [ drop successors>> first ] [ nip ] if
@ -12,9 +14,13 @@ IN: compiler.cfg.useless-blocks
] change-successors drop ; ] change-successors drop ;
: update-successor-for-delete ( bb -- ) : update-successor-for-delete ( bb -- )
[ predecessors>> first ] ! We have to replace occurrences of bb with bb's predecessor
[ successors>> first predecessors>> ] ! in bb's sucessor's list of predecessors.
bi set-first ; dup successors>> first [
[
2dup eq? [ drop predecessors>> first ] [ nip ] if
] with map
] change-predecessors drop ;
: delete-basic-block ( bb -- ) : delete-basic-block ( bb -- )
[ update-predecessor-for-delete ] [ update-predecessor-for-delete ]
@ -23,17 +29,17 @@ IN: compiler.cfg.useless-blocks
: delete-basic-block? ( bb -- ? ) : delete-basic-block? ( bb -- ? )
{ {
{ [ dup instructions>> length 1 = not ] [ f ] } [ instructions>> length 1 = ]
{ [ dup predecessors>> length 1 = not ] [ f ] } [ predecessors>> length 1 = ]
{ [ dup successors>> length 1 = not ] [ f ] } [ successors>> length 1 = ]
{ [ dup instructions>> first ##branch? not ] [ f ] } [ instructions>> first ##branch? ]
[ t ] } 1&& ;
} cond nip ;
: delete-useless-blocks ( cfg -- cfg' ) : delete-useless-blocks ( cfg -- cfg' )
dup [ dup [
dup delete-basic-block? [ delete-basic-block ] [ drop ] if dup delete-basic-block? [ delete-basic-block ] [ drop ] if
] each-basic-block ; ] each-basic-block
f >>post-order ;
: delete-conditional? ( bb -- ? ) : delete-conditional? ( bb -- ? )
dup instructions>> [ drop f ] [ dup instructions>> [ drop f ] [
@ -46,10 +52,11 @@ IN: compiler.cfg.useless-blocks
: delete-conditional ( bb -- ) : delete-conditional ( bb -- )
dup successors>> first 1vector >>successors dup successors>> first 1vector >>successors
[ but-last f \ ##branch boa suffix ] change-instructions [ but-last \ ##branch new-insn suffix ] change-instructions
drop ; drop ;
: delete-useless-conditionals ( cfg -- cfg' ) : delete-useless-conditionals ( cfg -- cfg' )
dup [ dup [
dup delete-conditional? [ delete-conditional ] [ drop ] if dup delete-conditional? [ delete-conditional ] [ drop ] if
] each-basic-block ; ] each-basic-block
f >>post-order ;

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences locals USING: kernel accessors namespaces assocs sets sequences locals
compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop ; compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop
compiler.cfg.liveness compiler.cfg.local ;
IN: compiler.cfg.write-barrier IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits. ! Eliminate redundant write barrier hits.
@ -35,8 +36,11 @@ M: ##set-slot-imm eliminate-write-barrier
M: insn eliminate-write-barrier ; M: insn eliminate-write-barrier ;
: eliminate-write-barriers ( insns -- insns' ) : write-barriers-step ( insns -- insns' )
H{ } clone safe set H{ } clone safe set
H{ } clone mutated set H{ } clone mutated set
H{ } clone copies set H{ } clone copies set
[ eliminate-write-barrier ] map sift ; [ eliminate-write-barrier ] map sift ;
: eliminate-write-barriers ( cfg -- cfg' )
[ drop ] [ write-barriers-step ] local-optimization ;

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

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

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

@ -26,14 +26,6 @@ SYMBOL: registers
: ?register ( obj -- operand ) : ?register ( obj -- operand )
dup vreg? [ register ] when ; dup vreg? [ register ] when ;
: generate-insns ( insns -- code )
[
[
dup regs>> registers set
generate-insn
] each
] { } make fixup ;
TUPLE: asm label code calls ; TUPLE: asm label code calls ;
SYMBOL: calls SYMBOL: calls
@ -51,17 +43,22 @@ SYMBOL: labels
: init-generator ( word -- ) : init-generator ( word -- )
H{ } clone labels set H{ } clone labels set
V{ } clone literal-table set
V{ } clone calls set V{ } clone calls set
compiling-word set compiling-word set
compiled-stack-traces? [ compiling-word get add-literal ] when ; compiled-stack-traces? [ compiling-word get add-literal ] when ;
: generate-insns ( asm -- code )
[
[ word>> init-generator ]
[
instructions>>
[ [ regs>> registers set ] [ generate-insn ] bi ] each
] bi
] with-fixup ;
: generate ( mr -- asm ) : generate ( mr -- asm )
[ [
[ label>> ] [ label>> ] [ generate-insns ] bi calls get
[ word>> init-generator ]
[ instructions>> generate-insns ] tri
calls get
asm boa asm boa
] with-scope ; ] with-scope ;
@ -92,10 +89,11 @@ M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
M: ##return generate-insn drop %return ; M: ##return generate-insn drop %return ;
M: ##dispatch-label generate-insn label>> %dispatch-label ; M: _dispatch generate-insn
[ src>> register ] [ temp>> register ] bi %dispatch ;
M: ##dispatch generate-insn M: _dispatch-label generate-insn
[ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ; label>> lookup-label %dispatch-label ;
: >slot< ( insn -- dst obj slot tag ) : >slot< ( insn -- dst obj slot tag )
{ {
@ -236,7 +234,7 @@ M: ##write-barrier generate-insn
[ table>> register ] [ table>> register ]
tri %write-barrier ; tri %write-barrier ;
M: _gc generate-insn drop %gc ; M: ##gc generate-insn drop %gc ;
M: ##loop-entry generate-insn drop %loop-entry ; M: ##loop-entry generate-insn drop %loop-entry ;
@ -486,7 +484,7 @@ M: _epilogue generate-insn
stack-frame>> total-size>> %epilogue ; stack-frame>> total-size>> %epilogue ;
M: _label generate-insn M: _label generate-insn
id>> lookup-label , ; id>> lookup-label resolve-label ;
M: _branch generate-insn M: _branch generate-insn
label>> lookup-label %jump-label ; label>> lookup-label %jump-label ;

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

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

40
basis/compiler/compiler.factor
View File

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

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

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

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

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

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 ; classes alien byte-arrays combinators words sets fry ;
IN: cpu.architecture IN: cpu.architecture
! Labels
TUPLE: label offset ;
: <label> ( -- label ) label new ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
! Register classes ! Register classes
SINGLETON: int-regs SINGLETON: int-regs
SINGLETON: single-float-regs SINGLETON: single-float-regs
@ -51,8 +44,8 @@ HOOK: %jump cpu ( word -- )
HOOK: %jump-label cpu ( label -- ) HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- ) HOOK: %return cpu ( -- )
HOOK: %dispatch cpu ( src temp offset -- ) HOOK: %dispatch cpu ( src temp -- )
HOOK: %dispatch-label cpu ( word -- ) HOOK: %dispatch-label cpu ( label -- )
HOOK: %slot cpu ( dst obj slot tag temp -- ) HOOK: %slot cpu ( dst obj slot tag temp -- )
HOOK: %slot-imm cpu ( dst obj slot tag -- ) HOOK: %slot-imm cpu ( dst obj slot tag -- )

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

@ -124,16 +124,13 @@ M: ppc %jump ( word -- )
M: ppc %jump-label ( label -- ) B ; M: ppc %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ; M: ppc %return ( -- ) BLR ;
M:: ppc %dispatch ( src temp offset -- ) M:: ppc %dispatch ( src temp -- )
0 temp LOAD32 0 temp LOAD32
4 offset + cells rc-absolute-ppc-2/2 rel-here 4 cells rc-absolute-ppc-2/2 rel-here
temp temp src LWZX temp temp src LWZX
temp MTCTR temp MTCTR
BCTR ; BCTR ;
M: ppc %dispatch-label ( word -- )
B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
:: (%slot) ( obj slot tag temp -- reg offset ) :: (%slot) ( obj slot tag temp -- reg offset )
temp slot obj ADD temp slot obj ADD
temp tag neg ; inline temp tag neg ; inline

9
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-1 ECX ;
M: x86.32 temp-reg-2 EDX ; M: x86.32 temp-reg-2 EDX ;
M:: x86.32 %dispatch ( src temp offset -- ) M:: x86.32 %dispatch ( src temp -- )
! Load jump table base. ! Load jump table base.
src HEX: ffffffff ADD src HEX: ffffffff ADD
offset cells rc-absolute-cell rel-here 0 rc-absolute-cell rel-here
! Go ! Go
src HEX: 7f [+] JMP src HEX: 7f [+] JMP
! Fix up the displacement above ! Fix up the displacement above
@ -305,10 +305,7 @@ os windows? [
4 "double" c-type (>>align) 4 "double" c-type (>>align)
] unless ] unless
FUNCTION: bool check_sse2 ( ) ; USING: cpu.x86.features cpu.x86.features.private ;
: sse2? ( -- ? )
check_sse2 ;
"-no-sse2" (command-line) member? [ "-no-sse2" (command-line) member? [
[ { check_sse2 } compile ] with-optimizer [ { check_sse2 } compile ] with-optimizer

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 rs-reg R15 ;
M: x86.64 stack-reg RSP ; M: x86.64 stack-reg RSP ;
M:: x86.64 %dispatch ( src temp offset -- ) M:: x86.64 %dispatch ( src temp -- )
! Load jump table base. ! Load jump table base.
temp HEX: ffffffff MOV temp HEX: ffffffff MOV
offset cells rc-absolute-cell rel-here 0 rc-absolute-cell rel-here
! Add jump table base ! Add jump table base
src temp ADD src temp ADD
src HEX: 7f [+] JMP src HEX: 7f [+] JMP

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

@ -0,0 +1 @@
Slava Pestov

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

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

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

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

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 ; M: x86 %return ( -- ) 0 RET ;
: code-alignment ( align -- n ) : code-alignment ( align -- n )
[ building get [ integer? ] count dup ] dip align swap - ; [ building get length dup ] dip align swap - ;
: align-code ( n -- ) : align-code ( n -- )
0 <repetition> % ; 0 <repetition> % ;
M: x86 %dispatch-label ( word -- ) M: x86 %dispatch-label ( label -- )
0 cell, rc-absolute-cell rel-word ; 0 cell, rc-absolute-cell label-fixup ;
:: (%slot) ( obj slot tag temp -- op ) :: (%slot) ( obj slot tag temp -- op )
temp slot obj [+] LEA temp slot obj [+] LEA

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

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

2
basis/http/server/server.factor
View File

@ -269,7 +269,7 @@ M: http-server handle-client*
] with-destructors ; ] with-destructors ;
: <http-server> ( -- server ) : <http-server> ( -- server )
http-server new-threaded-server ascii http-server new-threaded-server
"http.server" >>name "http.server" >>name
"http" protocol-port >>insecure "http" protocol-port >>insecure
"https" protocol-port >>secure ; "https" protocol-port >>secure ;

6
basis/io/servers/connection/connection-docs.factor
View File

@ -79,12 +79,12 @@ HELP: threaded-server
{ $class-description "The class of threaded servers. New instances are created with " { $link <threaded-server> } ". This class may be subclassed, and instances of subclasses should be created with " { $link new-threaded-server } ". See " { $link "server-config" } " for slot documentation." } ; { $class-description "The class of threaded servers. New instances are created with " { $link <threaded-server> } ". This class may be subclassed, and instances of subclasses should be created with " { $link new-threaded-server } ". See " { $link "server-config" } " for slot documentation." } ;
HELP: new-threaded-server HELP: new-threaded-server
{ $values { "class" class } { "threaded-server" threaded-server } } { $values { "encoding" "an encoding descriptor" } { "class" class } { "threaded-server" threaded-server } }
{ $description "Creates a new instance of a subclass of " { $link threaded-server } ". Subclasses can implement the " { $link handle-client* } " generic word." } ; { $description "Creates a new instance of a subclass of " { $link threaded-server } ". Subclasses can implement the " { $link handle-client* } " generic word." } ;
HELP: <threaded-server> HELP: <threaded-server>
{ $values { "threaded-server" threaded-server } } { $values { "encoding" "an encoding descriptor" } { "threaded-server" threaded-server } }
{ $description "Creates a new threaded server. Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ; { $description "Creates a new threaded server with streams encoded " { $snippet "encoding" } ". Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ;
HELP: remote-address HELP: remote-address
{ $var-description "Variable holding the address specifier of the current client connection. See " { $link "network-addressing" } "." } ; { $var-description "Variable holding the address specifier of the current client connection. See " { $link "network-addressing" } "." } ;

10
basis/io/servers/connection/connection-tests.factor
View File

@ -3,10 +3,10 @@ USING: tools.test io.servers.connection io.sockets namespaces
io.servers.connection.private kernel accessors sequences io.servers.connection.private kernel accessors sequences
concurrency.promises io.encodings.ascii io threads calendar ; concurrency.promises io.encodings.ascii io threads calendar ;
[ t ] [ <threaded-server> listen-on empty? ] unit-test [ t ] [ ascii <threaded-server> listen-on empty? ] unit-test
[ f ] [ [ f ] [
<threaded-server> ascii <threaded-server>
25 internet-server >>insecure 25 internet-server >>insecure
listen-on listen-on
empty? empty?
@ -19,16 +19,16 @@ concurrency.promises io.encodings.ascii io threads calendar ;
and and
] unit-test ] unit-test
[ ] [ <threaded-server> init-server drop ] unit-test [ ] [ ascii <threaded-server> init-server drop ] unit-test
[ 10 ] [ [ 10 ] [
<threaded-server> ascii <threaded-server>
10 >>max-connections 10 >>max-connections
init-server semaphore>> count>> init-server semaphore>> count>>
] unit-test ] unit-test
[ ] [ [ ] [
<threaded-server> ascii <threaded-server>
5 >>max-connections 5 >>max-connections
0 >>insecure 0 >>insecure
[ "Hello world." write stop-this-server ] >>handler [ "Hello world." write stop-this-server ] >>handler

6
basis/io/servers/connection/connection.factor
View File

@ -27,18 +27,18 @@ ready ;
: internet-server ( port -- addrspec ) f swap <inet> ; : internet-server ( port -- addrspec ) f swap <inet> ;
: new-threaded-server ( class -- threaded-server ) : new-threaded-server ( encoding class -- threaded-server )
new new
swap >>encoding
"server" >>name "server" >>name
DEBUG >>log-level DEBUG >>log-level
ascii >>encoding
1 minutes >>timeout 1 minutes >>timeout
V{ } clone >>sockets V{ } clone >>sockets
<secure-config> >>secure-config <secure-config> >>secure-config
[ "No handler quotation" throw ] >>handler [ "No handler quotation" throw ] >>handler
<flag> >>ready ; inline <flag> >>ready ; inline
: <threaded-server> ( -- threaded-server ) : <threaded-server> ( encoding -- threaded-server )
threaded-server new-threaded-server ; threaded-server new-threaded-server ;
GENERIC: handle-client* ( threaded-server -- ) GENERIC: handle-client* ( threaded-server -- )

1
basis/math/functions/functions-tests.factor
View File

@ -162,3 +162,4 @@ IN: math.functions.tests
[ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test [ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test
[ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test [ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test
[ C{ 1 2 } ] [ C{ 1 2 } 1 ^ ] unit-test

5
basis/math/functions/functions.factor
View File

@ -34,8 +34,9 @@ M: integer ^n
M: ratio ^n M: ratio ^n
[ >fraction ] dip [ ^n ] curry bi@ / ; [ >fraction ] dip [ ^n ] curry bi@ / ;
M: float ^n M: float ^n (^n) ;
(^n) ;
M: complex ^n (^n) ;
: integer^ ( x y -- z ) : integer^ ( x y -- z )
dup 0 > [ ^n ] [ neg ^n recip ] if ; inline dup 0 > [ ^n ] [ neg ^n recip ] if ; inline

1
build-support/factor.sh
View File

@ -174,6 +174,7 @@ find_os() {
CYGWIN_NT-5.2-WOW64) OS=winnt;; CYGWIN_NT-5.2-WOW64) OS=winnt;;
*CYGWIN_NT*) OS=winnt;; *CYGWIN_NT*) OS=winnt;;
*CYGWIN*) OS=winnt;; *CYGWIN*) OS=winnt;;
MINGW32*) OS=winnt;;
*darwin*) OS=macosx;; *darwin*) OS=macosx;;
*Darwin*) OS=macosx;; *Darwin*) OS=macosx;;
*linux*) OS=linux;; *linux*) OS=linux;;

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

@ -130,3 +130,7 @@ unit-test
[ 1 f ] [ 1 H{ } ?at ] unit-test [ 1 f ] [ 1 H{ } ?at ] unit-test
[ 2 t ] [ 1 H{ { 1 2 } } ?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 ? ) : ?at ( key assoc -- value/key ? )
2dup at* [ 2nip t ] [ 2drop f ] if ; inline 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 <PRIVATE
: (assoc-each) ( assoc quot -- seq quot' ) : (assoc-each) ( assoc quot -- seq quot' )

2
core/classes/parser/parser.factor
View File

@ -6,7 +6,7 @@ IN: classes.parser
: save-class-location ( class -- ) : save-class-location ( class -- )
location remember-class ; location remember-class ;
: create-class-in ( word -- word ) : create-class-in ( string -- word )
current-vocab create current-vocab create
dup save-class-location dup save-class-location
dup predicate-word dup set-word save-location ; dup predicate-word dup set-word save-location ;

1
extra/cursors/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

21
extra/cursors/cursors-tests.factor Normal file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: cursors math tools.test make ;
IN: cursors.tests
[ 2 t ] [ { 2 3 } [ even? ] find ] unit-test
[ 3 t ] [ { 2 3 } [ odd? ] find ] unit-test
[ f f ] [ { 2 4 } [ odd? ] find ] unit-test
[ { 2 3 } ] [ { 1 2 } [ 1 + ] map ] unit-test
[ { 2 3 } ] [ { 1 2 } [ [ 1 + , ] each ] { 2 3 } make ] unit-test
[ t ] [ { } [ odd? ] all? ] unit-test
[ t ] [ { 1 3 5 } [ odd? ] all? ] unit-test
[ f ] [ { 1 3 5 6 } [ odd? ] all? ] unit-test
[ t ] [ { } [ odd? ] all? ] unit-test
[ t ] [ { 1 3 5 } [ odd? ] any? ] unit-test
[ f ] [ { 2 4 6 } [ odd? ] any? ] unit-test
[ { 1 3 5 } ] [ { 1 2 3 4 5 6 } [ odd? ] filter ] unit-test

101
extra/cursors/cursors.factor Normal file
View File

@ -0,0 +1,101 @@
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math sequences sequences.private ;
IN: cursors
GENERIC: cursor-done? ( cursor -- ? )
GENERIC: cursor-get-unsafe ( cursor -- obj )
GENERIC: cursor-advance ( cursor -- )
GENERIC: cursor-valid? ( cursor -- ? )
GENERIC: cursor-write ( obj cursor -- )
ERROR: cursor-ended cursor ;
: cursor-get ( cursor -- obj )
dup cursor-done?
[ cursor-ended ] [ cursor-get-unsafe ] if ; 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 cursor-until ; inline
: cursor-find ( cursor quot -- obj ? )
[ cursor-until ] [ drop ] 2bi
dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
: cursor-any? ( cursor quot -- ? )
cursor-find nip ; inline
: cursor-all? ( cursor quot -- ? )
[ not ] compose cursor-any? not ; inline
: cursor-map-quot ( quot to -- quot' )
[ [ call ] dip cursor-write ] 2curry ; inline
: cursor-map ( from to quot -- )
swap cursor-map-quot cursor-each ; inline
: cursor-write-if ( obj quot to -- )
[ over [ call ] dip ] dip
[ cursor-write ] 2curry when ; inline
: cursor-filter-quot ( quot to -- quot' )
[ cursor-write-if ] 2curry ; inline
: cursor-filter ( from to quot -- )
swap cursor-filter-quot cursor-each ; inline
TUPLE: from-sequence { seq sequence } { n integer } ;
: >from-sequence< ( from-sequence -- n seq )
[ n>> ] [ seq>> ] bi ; inline
M: from-sequence cursor-done? ( cursor -- ? )
>from-sequence< length >= ;
M: from-sequence cursor-valid?
>from-sequence< bounds-check? not ;
M: from-sequence cursor-get-unsafe
>from-sequence< nth-unsafe ;
M: from-sequence cursor-advance
[ 1+ ] change-n drop ;
: >input ( seq -- cursor )
0 from-sequence boa ; inline
: iterate ( seq quot iterator -- )
[ >input ] 2dip call ; inline
: each ( seq quot -- ) [ cursor-each ] iterate ; inline
: find ( seq quot -- ? ) [ cursor-find ] iterate ; inline
: any? ( seq quot -- ? ) [ cursor-any? ] iterate ; inline
: all? ( seq quot -- ? ) [ cursor-all? ] iterate ; inline
TUPLE: to-sequence { seq sequence } { exemplar sequence } ;
M: to-sequence cursor-write
seq>> push ;
: freeze ( cursor -- seq )
[ seq>> ] [ exemplar>> ] bi like ; inline
: >output ( seq -- cursor )
[ [ length ] keep new-resizable ] keep
to-sequence boa ; inline
: transform ( seq quot transformer -- newseq )
[ [ >input ] [ >output ] bi ] 2dip
[ call ]
[ 2drop freeze ] 3bi ; inline
: map ( seq quot -- ) [ cursor-map ] transform ; inline
: filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline

3
extra/fuel/remote/remote.factor
View File

@ -11,9 +11,8 @@ IN: fuel.remote
[ [ print-error-and-restarts ] error-hook set listener ] with-scope ; [ [ print-error-and-restarts ] error-hook set listener ] with-scope ;
: server ( port -- server ) : server ( port -- server )
<threaded-server> utf8 <threaded-server>
"tty-server" >>name "tty-server" >>name
utf8 >>encoding
swap local-server >>insecure swap local-server >>insecure
[ start-listener ] >>handler [ start-listener ] >>handler
f >>timeout ; f >>timeout ;

10
extra/fuel/xref/xref.factor
View File

@ -23,13 +23,13 @@ IN: fuel.xref
dup dup >vocab-link where normalize-loc 4array ; dup dup >vocab-link where normalize-loc 4array ;
: sort-xrefs ( seq -- seq' ) : sort-xrefs ( seq -- seq' )
[ [ first ] dip first <=> ] sort ; inline [ [ first ] dip first <=> ] sort ;
: format-xrefs ( seq -- seq' ) : format-xrefs ( seq -- seq' )
[ word? ] filter [ word>xref ] map ; inline [ word? ] filter [ word>xref ] map ;
: filter-prefix ( seq prefix -- seq ) : filter-prefix ( seq prefix -- seq )
[ drop-prefix nip length 0 = ] curry filter prune ; inline [ drop-prefix nip length 0 = ] curry filter prune ;
MEMO: (vocab-words) ( name -- seq ) MEMO: (vocab-words) ( name -- seq )
>vocab-link words [ name>> ] map ; >vocab-link words [ name>> ] map ;
@ -37,10 +37,10 @@ MEMO: (vocab-words) ( name -- seq )
: current-words ( -- seq ) : current-words ( -- seq )
manifest get manifest get
[ search-vocabs>> ] [ qualified-vocabs>> ] bi [ words>> ] bi@ [ search-vocabs>> ] [ qualified-vocabs>> ] bi [ words>> ] bi@
assoc-union keys ; inline assoc-union keys ;
: vocabs-words ( names -- seq ) : vocabs-words ( names -- seq )
prune [ (vocab-words) ] map concat ; inline prune [ (vocab-words) ] map concat ;
PRIVATE> PRIVATE>

1
extra/managed-server/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
extra/managed-server/chat/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

135
extra/managed-server/chat/chat.factor Normal file
View File

@ -0,0 +1,135 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators combinators.smart
destructors fry io io.encodings.utf8 kernel managed-server
namespaces parser sequences sorting splitting strings.parser
unicode.case unicode.categories calendar calendar.format
locals multiline io.encodings.binary io.encodings.string
prettyprint ;
IN: managed-server.chat
TUPLE: chat-server < managed-server ;
SYMBOL: commands
commands [ H{ } clone ] initialize
SYMBOL: chat-docs
chat-docs [ H{ } clone ] initialize
CONSTANT: line-beginning "-!- "
: send-line ( string -- )
write "\r\n" write flush ;
: handle-me ( string -- )
[
[ "* " username " " ] dip
] "" append-outputs-as send-everyone ;
: handle-quit ( string -- )
client [ (>>object) ] [ t >>quit? drop ] bi ;
: handle-help ( string -- )
[
"Commands: "
commands get keys natural-sort ", " join append send-line
] [
chat-docs get ?at
[ send-line ]
[ "Unknown command: " prepend send-line ] if
] if-empty ;
: usage ( string -- )
chat-docs get at send-line ;
: username-taken-string ( username -- string )
"The username ``" "'' is already in use; try again." surround ;
: warn-name-changed ( old new -- )
[
[ line-beginning "``" ] 2dip
[ "'' is now known as ``" ] dip "''"
] "" append-outputs-as send-everyone ;
: handle-nick ( string -- )
[
"nick" usage
] [
dup clients key? [
username-taken-string send-line
] [
[ username swap warn-name-changed ]
[ username clients rename-at ]
[ client (>>username) ] tri
] if
] if-empty ;
:: add-command ( quot docs key -- )
quot key commands get set-at
docs key chat-docs get set-at ;
[ handle-help ]
<" Syntax: /help [command]
Displays the documentation for a command.">
"help" add-command
[ drop clients keys [ "``" "''" surround ] map ", " join send-line ]
<" Syntax: /who
Shows the list of connected users.">
"who" add-command
[ drop gmt timestamp>rfc822 send-line ]
<" Syntax: /time
Returns the current GMT time."> "time" add-command
[ handle-nick ]
<" Syntax: /nick nickname
Changes your nickname.">
"nick" add-command
[ handle-me ]
<" Syntax: /me action">
"me" add-command
[ handle-quit ]
<" Syntax: /quit [message]
Disconnects a user from the chat server."> "quit" add-command
: handle-command ( string -- )
dup " " split1 swap >lower commands get at* [
call( string -- ) drop
] [
2drop "Unknown command: " prepend send-line
] if ;
: <chat-server> ( port -- managed-server )
"chat-server" utf8 chat-server new-managed-server ;
: handle-chat ( string -- )
[
[ username ": " ] dip
] "" append-outputs-as send-everyone ;
M: chat-server handle-login
"Username: " write flush
readln ;
M: chat-server handle-client-join
[
line-beginning username " has joined"
] "" append-outputs-as send-everyone ;
M: chat-server handle-client-disconnect
[
line-beginning username " has quit "
client object>> dup [ "\"" dup surround ] when
] "" append-outputs-as send-everyone ;
M: chat-server handle-already-logged-in
username username-taken-string send-line ;
M: chat-server handle-managed-client*
readln dup f = [ t client (>>quit?) ] when
[
"/" ?head [ handle-command ] [ handle-chat ] if
] unless-empty ;

92
extra/managed-server/managed-server.factor Normal file
View File

@ -0,0 +1,92 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs calendar continuations destructors io
io.encodings.binary io.servers.connection io.sockets
io.streams.duplex fry kernel locals math math.ranges multiline
namespaces prettyprint random sequences sets splitting threads
tools.continuations ;
IN: managed-server
TUPLE: managed-server < threaded-server clients ;
TUPLE: managed-client
input-stream output-stream local-address remote-address
username object quit? ;
HOOK: handle-login threaded-server ( -- username )
HOOK: handle-managed-client* managed-server ( -- )
HOOK: handle-already-logged-in managed-server ( -- )
HOOK: handle-client-join managed-server ( -- )
HOOK: handle-client-disconnect managed-server ( -- )
ERROR: already-logged-in username ;
M: managed-server handle-already-logged-in already-logged-in ;
M: managed-server handle-client-join ;
M: managed-server handle-client-disconnect ;
: server ( -- managed-client ) managed-server get ;
: client ( -- managed-client ) managed-client get ;
: clients ( -- assoc ) server clients>> ;
: client-streams ( -- assoc ) clients values ;
: username ( -- string ) client username>> ;
: everyone-else ( -- assoc )
clients [ drop username = not ] assoc-filter ;
: everyone-else-streams ( -- assoc ) everyone-else values ;
ERROR: no-such-client username ;
<PRIVATE
: (send-client) ( managed-client seq -- )
[ output-stream>> ] dip '[ _ print flush ] with-output-stream* ;
PRIVATE>
: send-client ( seq username -- )
clients ?at [ no-such-client ] [ (send-client) ] if ;
: send-everyone ( seq -- )
[ client-streams ] dip '[ _ (send-client) ] each ;
: send-everyone-else ( seq -- )
[ everyone-else-streams ] dip '[ _ (send-client) ] each ;
<PRIVATE
: <managed-client> ( username -- managed-client )
managed-client new
swap >>username
input-stream get >>input-stream
output-stream get >>output-stream
local-address get >>local-address
remote-address get >>remote-address ;
: check-logged-in ( username -- username )
dup clients key? [ handle-already-logged-in ] when ;
: add-managed-client ( -- )
client username check-logged-in clients set-at ;
: delete-managed-client ( -- )
username server clients>> delete-at ;
: handle-managed-client ( -- )
handle-login <managed-client> managed-client set
add-managed-client handle-client-join
[ handle-managed-client* client quit?>> not ] loop ;
PRIVATE>
M: managed-server handle-client*
managed-server set
[ handle-managed-client ]
[ delete-managed-client handle-client-disconnect ]
[ ] cleanup ;
: new-managed-server ( port name encoding class -- server )
new-threaded-server
swap >>name
swap >>insecure
f >>timeout
H{ } clone >>clients ; inline

3
extra/mongodb/mmm/mmm.factor
View File

@ -89,9 +89,8 @@ M: mdb-msg dump-message ( message -- )
: start-mmm-server ( -- ) : start-mmm-server ( -- )
output-stream get mmm-dump-output set output-stream get mmm-dump-output set
<threaded-server> [ mmm-t-srv set ] keep binary <threaded-server> [ mmm-t-srv set ] keep
"127.0.0.1" mmm-port get <inet4> >>insecure "127.0.0.1" mmm-port get <inet4> >>insecure
binary >>encoding
[ handle-mmm-connection ] >>handler [ handle-mmm-connection ] >>handler
start-server* ; start-server* ;

16
extra/nurbs/nurbs-tests.factor
View File

@ -11,13 +11,13 @@ CONSTANT: -√2/2 $[ 0.5 sqrt neg ]
! unit circle as NURBS ! unit circle as NURBS
3 { 3 {
{ 1.0 0.0 1.0 } { 1.0 0.0 1.0 }
{ $ √2/2 $ √2/2 $ √2/2 } ${ √2/2 √2/2 √2/2 }
{ 0.0 1.0 1.0 } { 0.0 1.0 1.0 }
{ $ -√2/2 $ √2/2 $ √2/2 } ${ -√2/2 √2/2 √2/2 }
{ -1.0 0.0 1.0 } { -1.0 0.0 1.0 }
{ $ -√2/2 $ -√2/2 $ √2/2 } ${ -√2/2 -√2/2 √2/2 }
{ 0.0 -1.0 1.0 } { 0.0 -1.0 1.0 }
{ $ √2/2 $ -√2/2 $ √2/2 } ${ √2/2 -√2/2 √2/2 }
{ 1.0 0.0 1.0 } { 1.0 0.0 1.0 }
} { 0.0 0.0 0.0 0.25 0.25 0.5 0.5 0.75 0.75 1.0 1.0 1.0 } <nurbs-curve> test-nurbs set } { 0.0 0.0 0.0 0.25 0.25 0.5 0.5 0.75 0.75 1.0 1.0 1.0 } <nurbs-curve> test-nurbs set
@ -26,7 +26,7 @@ CONSTANT: -√2/2 $[ 0.5 sqrt neg ]
[ t ] [ test-nurbs get 0.5 eval-nurbs { -1.0 0.0 } 0.00001 v~ ] unit-test [ t ] [ test-nurbs get 0.5 eval-nurbs { -1.0 0.0 } 0.00001 v~ ] unit-test
[ t ] [ test-nurbs get 0.75 eval-nurbs { 0.0 -1.0 } 0.00001 v~ ] unit-test [ t ] [ test-nurbs get 0.75 eval-nurbs { 0.0 -1.0 } 0.00001 v~ ] unit-test
[ t ] [ test-nurbs get 0.125 eval-nurbs { $ √2/2 $ √2/2 } 0.00001 v~ ] unit-test [ t ] [ test-nurbs get 0.125 eval-nurbs ${ √2/2 √2/2 } 0.00001 v~ ] unit-test
[ t ] [ test-nurbs get 0.375 eval-nurbs { $ -√2/2 $ √2/2 } 0.00001 v~ ] unit-test [ t ] [ test-nurbs get 0.375 eval-nurbs ${ -√2/2 √2/2 } 0.00001 v~ ] unit-test
[ t ] [ test-nurbs get 0.625 eval-nurbs { $ -√2/2 $ -√2/2 } 0.00001 v~ ] unit-test [ t ] [ test-nurbs get 0.625 eval-nurbs ${ -√2/2 -√2/2 } 0.00001 v~ ] unit-test
[ t ] [ test-nurbs get 0.875 eval-nurbs { $ √2/2 $ -√2/2 } 0.00001 v~ ] unit-test [ t ] [ test-nurbs get 0.875 eval-nurbs ${ √2/2 -√2/2 } 0.00001 v~ ] unit-test

4
extra/sequences/product/product-docs.factor
View File

@ -1,6 +1,6 @@
! (c)2009 Joe Groff bsd license ! (c)2009 Joe Groff bsd license
USING: help.markup help.syntax multiline quotations sequences sequences.product ; USING: help.markup help.syntax multiline quotations sequences ;
IN: sequences IN: sequences.product
HELP: product-sequence HELP: product-sequence
{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." } { $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }

6
extra/time-server/time-server.factor
View File

@ -1,14 +1,14 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io io.servers.connection accessors threads USING: accessors calendar calendar.format io io.encodings.ascii
calendar calendar.format ; io.servers.connection threads ;
IN: time-server IN: time-server
: handle-time-client ( -- ) : handle-time-client ( -- )
now timestamp>rfc822 print ; now timestamp>rfc822 print ;
: <time-server> ( -- threaded-server ) : <time-server> ( -- threaded-server )
<threaded-server> ascii <threaded-server>
"time-server" >>name "time-server" >>name
1234 >>insecure 1234 >>insecure
[ handle-time-client ] >>handler ; [ handle-time-client ] >>handler ;

3
extra/tty-server/tty-server.factor
View File

@ -3,9 +3,8 @@ accessors kernel ;
IN: tty-server IN: tty-server
: <tty-server> ( port -- ) : <tty-server> ( port -- )
<threaded-server> utf8 <threaded-server>
"tty-server" >>name "tty-server" >>name
utf8 >>encoding
swap local-server >>insecure swap local-server >>insecure
[ listener ] >>handler [ listener ] >>handler
start-server ; start-server ;

28
unmaintained/modules/rpc-server/rpc-server.factor
View File

@ -2,7 +2,6 @@ USING: accessors assocs continuations effects io
io.encodings.binary io.servers.connection kernel io.encodings.binary io.servers.connection kernel
memoize namespaces parser sets sequences serialize memoize namespaces parser sets sequences serialize
threads vocabs vocabs.parser words ; threads vocabs vocabs.parser words ;
IN: modules.rpc-server IN: modules.rpc-server
SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
@ -12,17 +11,24 @@ SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize : process ( vocabspec -- )
vocab-words [ deserialize ] dip deserialize
swap at "executer" get execute( args word -- bytes ) write flush ; swap at "executer" get execute( args word -- bytes ) write flush ;
: (serve) ( -- ) deserialize dup serving-vocabs get-global index : (serve) ( -- )
deserialize dup serving-vocabs get-global index
[ process ] [ drop ] if ; [ process ] [ drop ] if ;
: start-serving-vocabs ( -- ) [ : start-serving-vocabs ( -- )
<threaded-server> 5000 >>insecure binary >>encoding [ (serve) ] >>handler [
start-server ] in-thread ; binary <threaded-server>
5000 >>insecure
[ (serve) ] >>handler
start-server
] in-thread ;
: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when : (service) ( -- )
serving-vocabs get-global empty? [ start-serving-vocabs ] when
current-vocab serving-vocabs get-global adjoin current-vocab serving-vocabs get-global adjoin
"get-words" create-in "get-words" create-in
in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
@ -32,6 +38,8 @@ SYNTAX: service \ do-rpc "executer" set (service) ;
SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ; SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
load-vocab-hook [ load-vocab-hook [
[ dup words>> values [
\ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ] dup words>> values
append ] change-global \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each
] append
] change-global

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: case RT_XT_PIC_TAIL:
return (cell)word_xt_pic_tail(untag<word>(ARG)); return (cell)word_xt_pic_tail(untag<word>(ARG));
case RT_HERE: 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: case RT_THIS:
return (cell)(compiled + 1); return (cell)(compiled + 1);
case RT_STACK_CHAIN: case RT_STACK_CHAIN:

5
vm/cpu-x86.32.S
View File

@ -55,6 +55,10 @@ DEF(bool,check_sse2,(void)):
mov %edx,%eax mov %edx,%eax
ret ret
DEF(long long,read_timestamp_counter,(void)):
rdtsc
ret
DEF(void,primitive_inline_cache_miss,(void)): DEF(void,primitive_inline_cache_miss,(void)):
mov (%esp),%ebx mov (%esp),%ebx
DEF(void,primitive_inline_cache_miss_tail,(void)): DEF(void,primitive_inline_cache_miss_tail,(void)):
@ -69,4 +73,5 @@ DEF(void,primitive_inline_cache_miss_tail,(void)):
#ifdef WINDOWS #ifdef WINDOWS
.section .drectve .section .drectve
.ascii " -export:check_sse2" .ascii " -export:check_sse2"
.ascii " -export:read_timestamp_counter"
#endif #endif

7
vm/cpu-x86.64.S
View File

@ -72,6 +72,13 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi
call *ARG3 /* call memcpy */ call *ARG3 /* call memcpy */
ret /* return _with new stack_ */ ret /* return _with new stack_ */
DEF(long long,read_timestamp_counter,(void)):
mov $0,%rax
rdtsc
shl $32,%rdx
or %rdx,%rax
ret
DEF(void,primitive_inline_cache_miss,(void)): DEF(void,primitive_inline_cache_miss,(void)):
mov (%rsp),%rbx mov (%rsp),%rbx
DEF(void,primitive_inline_cache_miss_tail,(void)): DEF(void,primitive_inline_cache_miss_tail,(void)):