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

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

db4
Joe Groff 2009-07-23 13:39:52 -05:00
parent 733c208f8c dd2bbc51b3
commit 739d99d4e8
48 changed files with 928 additions and 304 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/calendar/unix/unix.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax arrays calendar
kernel math unix unix.time namespaces system ;
kernel math unix unix.time unix.types namespaces system ;
IN: calendar.unix
: timeval>seconds ( timeval -- seconds )
@ -19,7 +19,7 @@ IN: calendar.unix
timespec>seconds since-1970 ;
: get-time ( -- alien )
f time <uint> localtime ;
f time <time_t> localtime ;
: timezone-name ( -- string )
get-time tm-zone ;

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

@ -3,8 +3,7 @@
USING: kernel math namespaces assocs hashtables sequences arrays
accessors vectors combinators sets classes compiler.cfg
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.copy-prop compiler.cfg.rpo
compiler.cfg.liveness compiler.cfg.local ;
compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.liveness ;
IN: compiler.cfg.alias-analysis
! We try to eliminate redundant slot operations using some simple heuristics.
@ -197,7 +196,7 @@ M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
M: ##alien-global insn-object drop \ ##alien-global ;
: init-alias-analysis ( live-in -- )
: init-alias-analysis ( insns -- insns' )
H{ } clone histories set
H{ } clone vregs>acs set
H{ } clone acs>vregs set
@ -208,7 +207,7 @@ M: ##alien-global insn-object drop \ ##alien-global ;
0 ac-counter set
next-ac heap-ac set
[ set-heap-ac ] each ;
dup local-live-in [ set-heap-ac ] each ;
GENERIC: analyze-aliases* ( insn -- insn' )
@ -280,9 +279,10 @@ M: insn eliminate-dead-stores* ;
[ insn# set eliminate-dead-stores* ] map-index sift ;
: alias-analysis-step ( insns -- insns' )
init-alias-analysis
analyze-aliases
compute-live-stores
eliminate-dead-stores ;
: alias-analysis ( cfg -- cfg' )
[ init-alias-analysis ] [ alias-analysis-step ] local-optimization ;
[ alias-analysis-step ] local-optimization ;

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

@ -1,7 +1,7 @@
! 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
compiler.cfg.def-use compiler.cfg.linearization
combinators.short-circuit accessors math sequences sets assocs ;
IN: compiler.cfg.checker
@ -54,8 +54,6 @@ ERROR: undefined-values uses defs ;
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 ;
bi ;

140
basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor Normal file
View File

@ -0,0 +1,140 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs deques dlists kernel locals sequences lexer
namespaces functors compiler.cfg.rpo compiler.cfg.utilities
compiler.cfg ;
IN: compiler.cfg.dataflow-analysis
GENERIC: join-sets ( sets dfa -- set )
GENERIC: transfer-set ( in-set bb dfa -- out-set )
GENERIC: block-order ( cfg dfa -- bbs )
GENERIC: successors ( bb dfa -- seq )
GENERIC: predecessors ( bb dfa -- seq )
<PRIVATE
MIXIN: dataflow-analysis
: <dfa-worklist> ( cfg dfa -- queue )
block-order <hashed-dlist> [ push-all-front ] keep ;
GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
! M: kill-block compute-in-set 3drop f ;
M:: basic-block compute-in-set ( bb out-sets dfa -- set )
bb dfa predecessors [ out-sets at ] map dfa join-sets ;
:: update-in-set ( bb in-sets out-sets dfa -- ? )
bb out-sets dfa compute-in-set
bb in-sets maybe-set-at ; inline
GENERIC# compute-out-set 2 ( bb out-sets dfa -- set )
! M: kill-block compute-out-set 3drop f ;
M:: basic-block compute-out-set ( bb in-sets dfa -- set )
bb in-sets at bb dfa transfer-set ;
:: update-out-set ( bb in-sets out-sets dfa -- ? )
bb in-sets dfa compute-out-set
bb out-sets maybe-set-at ; inline
:: dfa-step ( bb in-sets out-sets dfa work-list -- )
bb in-sets out-sets dfa update-in-set [
bb in-sets out-sets dfa update-out-set [
bb dfa successors work-list push-all-front
] when
] when ; inline
:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets )
H{ } clone :> in-sets
H{ } clone :> out-sets
cfg dfa <dfa-worklist> :> work-list
work-list [ in-sets out-sets dfa work-list dfa-step ] slurp-deque
in-sets
out-sets ; inline
M: dataflow-analysis join-sets drop assoc-refine ;
FUNCTOR: define-analysis ( name -- )
name-analysis DEFINES-CLASS ${name}-analysis
name-ins DEFINES ${name}-ins
name-outs DEFINES ${name}-outs
name-in DEFINES ${name}-in
name-out DEFINES ${name}-out
WHERE
SINGLETON: name-analysis
SYMBOL: name-ins
: name-in ( bb -- set ) name-ins get at ;
SYMBOL: name-outs
: name-out ( bb -- set ) name-outs get at ;
;FUNCTOR
! ! ! Forward dataflow analysis
MIXIN: forward-analysis
INSTANCE: forward-analysis dataflow-analysis
M: forward-analysis block-order drop reverse-post-order ;
M: forward-analysis successors drop successors>> ;
M: forward-analysis predecessors drop predecessors>> ;
FUNCTOR: define-forward-analysis ( name -- )
name-analysis IS ${name}-analysis
name-ins IS ${name}-ins
name-outs IS ${name}-outs
compute-name-sets DEFINES compute-${name}-sets
WHERE
INSTANCE: name-analysis forward-analysis
: compute-name-sets ( cfg -- )
name-analysis run-dataflow-analysis
[ name-ins set ] [ name-outs set ] bi* ;
;FUNCTOR
! ! ! Backward dataflow analysis
MIXIN: backward-analysis
INSTANCE: backward-analysis dataflow-analysis
M: backward-analysis block-order drop post-order ;
M: backward-analysis successors drop predecessors>> ;
M: backward-analysis predecessors drop successors>> ;
FUNCTOR: define-backward-analysis ( name -- )
name-analysis IS ${name}-analysis
name-ins IS ${name}-ins
name-outs IS ${name}-outs
compute-name-sets DEFINES compute-${name}-sets
WHERE
INSTANCE: name-analysis backward-analysis
: compute-name-sets ( cfg -- )
\ name-analysis run-dataflow-analysis
[ name-outs set ] [ name-ins set ] bi* ;
;FUNCTOR
PRIVATE>
SYNTAX: FORWARD-ANALYSIS:
scan [ define-analysis ] [ define-forward-analysis ] bi ;
SYNTAX: BACKWARD-ANALYSIS:
scan [ define-analysis ] [ define-backward-analysis ] bi ;

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

@ -7,7 +7,7 @@ parser compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.registers compiler.cfg.stack-frame
compiler.cfg.linear-scan compiler.cfg.two-operand
compiler.cfg.liveness compiler.cfg.optimizer
compiler.cfg.optimizer
compiler.cfg.mr compiler.cfg ;
IN: compiler.cfg.debugger

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

@ -1,6 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel assocs compiler.cfg.instructions ;
USING: accessors arrays kernel assocs sequences
sets compiler.cfg.instructions ;
IN: compiler.cfg.def-use
GENERIC: defs-vregs ( insn -- seq )
@ -62,3 +63,12 @@ UNION: vreg-insn
_conditional-branch
_compare-imm-branch
_dispatch ;
: map-unique ( seq quot -- assoc )
map concat unique ; inline
: gen-set ( instructions -- seq )
[ uses-vregs ] map-unique ;
: kill-set ( instructions -- seq )
[ defs-vregs ] map-unique ;

97
basis/compiler/cfg/dominance/dominance-tests.factor Normal file
View File

@ -0,0 +1,97 @@
IN: compiler.cfg.dominance.tests
USING: tools.test sequences vectors namespaces kernel accessors assocs sets
math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger
compiler.cfg.predecessors ;
: test-dominance ( -- )
cfg new 0 get >>entry
compute-predecessors
compute-dominance ;
! Example with no back edges
V{ } 0 test-bb
V{ } 1 test-bb
V{ } 2 test-bb
V{ } 3 test-bb
V{ } 4 test-bb
V{ } 5 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
1 get 3 get 1vector >>successors drop
2 get 4 get 1vector >>successors drop
3 get 4 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
[ ] [ test-dominance ] unit-test
[ t ] [ 0 get dom-parent 0 get eq? ] unit-test
[ t ] [ 1 get dom-parent 0 get eq? ] unit-test
[ t ] [ 2 get dom-parent 0 get eq? ] unit-test
[ t ] [ 4 get dom-parent 0 get eq? ] unit-test
[ t ] [ 3 get dom-parent 1 get eq? ] unit-test
[ t ] [ 5 get dom-parent 4 get eq? ] unit-test
[ t ] [ 0 get dom-children 1 get 2 get 4 get 3array set= ] unit-test
[ { 4 } ] [ 1 get dom-frontier [ number>> ] map ] unit-test
[ { 4 } ] [ 2 get dom-frontier [ number>> ] map ] unit-test
[ { } ] [ 0 get dom-frontier ] unit-test
[ { } ] [ 4 get dom-frontier ] unit-test
! Example from the paper
V{ } 0 test-bb
V{ } 1 test-bb
V{ } 2 test-bb
V{ } 3 test-bb
V{ } 4 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
1 get 3 get 1vector >>successors drop
2 get 4 get 1vector >>successors drop
3 get 4 get 1vector >>successors drop
4 get 3 get 1vector >>successors drop
[ ] [ test-dominance ] unit-test
[ t ] [ 0 4 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test
! The other example from the paper
V{ } 0 test-bb
V{ } 1 test-bb
V{ } 2 test-bb
V{ } 3 test-bb
V{ } 4 test-bb
V{ } 5 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
1 get 5 get 1vector >>successors drop
2 get 4 get 3 get V{ } 2sequence >>successors drop
5 get 4 get 1vector >>successors drop
4 get 5 get 3 get V{ } 2sequence >>successors drop
3 get 4 get 1vector >>successors drop
[ ] [ test-dominance ] unit-test
[ t ] [ 0 5 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test
V{ } 0 test-bb
V{ } 1 test-bb
V{ } 2 test-bb
V{ } 3 test-bb
V{ } 4 test-bb
V{ } 5 test-bb
V{ } 6 test-bb
0 get 1 get 5 get V{ } 2sequence >>successors drop
1 get 2 get 3 get V{ } 2sequence >>successors drop
2 get 4 get 1vector >>successors drop
3 get 4 get 1vector >>successors drop
4 get 6 get 1vector >>successors drop
5 get 6 get 1vector >>successors drop
[ ] [ test-dominance ] unit-test
[ t ] [
2 get 3 get 2array iterated-dom-frontier
4 get 6 get 2array set=
] unit-test

102
basis/compiler/cfg/dominance/dominance.factor
View File

@ -1,8 +1,7 @@
! 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 ;
USING: accessors assocs combinators sets math fry kernel math.order
dlists deques namespaces sequences sorting compiler.cfg.rpo ;
IN: compiler.cfg.dominance
! Reference:
@ -11,31 +10,106 @@ IN: compiler.cfg.dominance
! 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 ;
! Also, a nice overview is given in these lecture notes:
! http://llvm.cs.uiuc.edu/~vadve/CS526/public_html/Notes/4ssa.4up.pdf
<PRIVATE
: set-idom ( idom bb -- changed? ) idoms get maybe-set-at ;
! Maps bb -> idom(bb)
SYMBOL: dom-parents
PRIVATE>
: dom-parent ( bb -- bb' ) dom-parents get at ;
<PRIVATE
: set-idom ( idom bb -- changed? )
dom-parents get maybe-set-at ;
: intersect ( finger1 finger2 -- bb )
2dup [ number>> ] compare {
{ +lt+ [ [ idom ] dip intersect ] }
{ +gt+ [ idom intersect ] }
{ +gt+ [ [ dom-parent ] dip intersect ] }
{ +lt+ [ dom-parent intersect ] }
[ 2drop ]
} case ;
: compute-idom ( bb -- idom )
predecessors>> [ idom ] map sift
predecessors>> [ dom-parent ] filter
[ ] [ intersect ] map-reduce ;
: iterate ( rpo -- changed? )
[ [ compute-idom ] keep set-idom ] map [ ] any? ;
: compute-dom-parents ( cfg -- )
H{ } clone dom-parents set
reverse-post-order
unclip dup set-idom drop '[ _ iterate ] loop ;
! Maps bb -> {bb' | idom(bb') = bb}
SYMBOL: dom-childrens
PRIVATE>
: compute-dominance ( cfg -- cfg )
H{ } clone idoms set
dup reverse-post-order
unclip dup set-idom drop '[ _ iterate ] loop ;
: dom-children ( bb -- seq ) dom-childrens get at ;
<PRIVATE
: compute-dom-children ( -- )
dom-parents get H{ } clone
[ '[ 2dup eq? [ 2drop ] [ _ push-at ] if ] assoc-each ] keep
dom-childrens set ;
! Maps bb -> DF(bb)
SYMBOL: dom-frontiers
PRIVATE>
: dom-frontier ( bb -- set ) dom-frontiers get at keys ;
<PRIVATE
: compute-dom-frontier ( bb pred -- )
2dup [ dom-parent ] dip eq? [ 2drop ] [
[ dom-frontiers get conjoin-at ]
[ dom-parent compute-dom-frontier ] 2bi
] if ;
: compute-dom-frontiers ( cfg -- )
H{ } clone dom-frontiers set
[
dup predecessors>> dup length 2 >= [
[ compute-dom-frontier ] with each
] [ 2drop ] if
] each-basic-block ;
PRIVATE>
: compute-dominance ( cfg -- )
[ compute-dom-parents compute-dom-children ]
[ compute-dom-frontiers ]
bi ;
<PRIVATE
SYMBOLS: work-list visited ;
: add-to-work-list ( bb -- )
dom-frontier work-list get push-all-front ;
: iterated-dom-frontier-step ( bb -- )
dup visited get key? [ drop ] [
[ visited get conjoin ]
[ add-to-work-list ] bi
] if ;
PRIVATE>
: iterated-dom-frontier ( bbs -- bbs' )
[
<dlist> work-list set
H{ } clone visited set
[ add-to-work-list ] each
work-list get [ iterated-dom-frontier-step ] slurp-deque
visited get keys
] with-scope ;

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

@ -4,6 +4,7 @@ USING: accessors kernel math assocs namespaces sequences heaps
fry make combinators sets locals
cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.def-use
compiler.cfg.liveness
compiler.cfg.registers
@ -185,6 +186,6 @@ ERROR: bad-vreg vreg ;
] V{ } make
] change-instructions drop ;
: assign-registers ( live-intervals rpo -- )
: assign-registers ( live-intervals cfg -- )
[ init-assignment ] dip
[ assign-registers-in-block ] each ;
[ assign-registers-in-block ] each-basic-block ;

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

@ -7,7 +7,6 @@ compiler.cfg
compiler.cfg.optimizer
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.liveness
compiler.cfg.predecessors
compiler.cfg.rpo
compiler.cfg.linearization
@ -1507,9 +1506,7 @@ SYMBOL: linear-scan-result
[
cfg new 0 get >>entry
compute-predecessors
compute-liveness
dup reverse-post-order
{ { int-regs regs } } (linear-scan)
dup { { int-regs regs } } (linear-scan)
cfg-changed
flatten-cfg 1array mr.
] with-scope ;
@ -2331,9 +2328,6 @@ test-diamond
! early in bootstrap on x86-32
[ t ] [
[
H{ } clone live-ins set
H{ } clone live-outs set
H{ } clone phi-live-ins set
T{ basic-block
{ id 12345 }
{ instructions
@ -2353,7 +2347,8 @@ test-diamond
T{ ##replace f V int-regs 5 D 0 }
}
}
} dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
} cfg new over >>entry
{ { int-regs V{ 0 1 2 3 } } } (linear-scan)
instructions>> first
live-values>> assoc-empty?
] with-scope

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

@ -4,6 +4,7 @@ USING: kernel accessors namespaces make locals
cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.liveness
compiler.cfg.instructions
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
@ -28,17 +29,18 @@ IN: compiler.cfg.linear-scan
! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
:: (linear-scan) ( rpo machine-registers -- )
rpo number-instructions
rpo compute-live-intervals machine-registers allocate-registers
rpo assign-registers
rpo resolve-data-flow
rpo check-numbering ;
:: (linear-scan) ( cfg machine-registers -- )
cfg compute-live-sets
cfg number-instructions
cfg compute-live-intervals machine-registers allocate-registers
cfg assign-registers
cfg resolve-data-flow
cfg check-numbering ;
: linear-scan ( cfg -- cfg' )
[
init-mapping
dup reverse-post-order machine-registers (linear-scan)
dup machine-registers (linear-scan)
spill-counts get >>spill-counts
cfg-changed
] with-scope ;

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

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math math.order fry
combinators binary-search compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.rpo
compiler.cfg ;
IN: compiler.cfg.linear-scan.live-intervals
TUPLE: live-range from to ;
@ -144,10 +145,10 @@ ERROR: bad-live-interval live-interval ;
} cleave
] each ;
: compute-live-intervals ( rpo -- live-intervals )
: compute-live-intervals ( cfg -- live-intervals )
H{ } clone [
live-intervals set
<reversed> [ compute-live-intervals-step ] each
post-order [ compute-live-intervals-step ] each
] keep values dup finish-live-intervals ;
: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )

9
basis/compiler/cfg/linear-scan/numbering/numbering.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math sequences grouping namespaces ;
USING: kernel accessors math sequences grouping namespaces
compiler.cfg.rpo ;
IN: compiler.cfg.linear-scan.numbering
: number-instructions ( rpo -- )
@ -8,7 +9,7 @@ IN: compiler.cfg.linear-scan.numbering
instructions>> [
[ (>>insn#) ] [ drop 2 + ] 2bi
] each
] each drop ;
] each-basic-block drop ;
SYMBOL: check-numbering?
@ -18,5 +19,5 @@ ERROR: bad-numbering bb ;
dup instructions>> [ insn#>> ] map sift [ <= ] monotonic?
[ drop ] [ bad-numbering ] if ;
: check-numbering ( rpo -- )
check-numbering? get [ [ check-block-numbering ] each ] [ drop ] if ;
: check-numbering ( cfg -- )
check-numbering? get [ [ check-block-numbering ] each-basic-block ] [ drop ] if ;

8
basis/compiler/cfg/linear-scan/resolve/resolve.factor
View File

@ -3,10 +3,12 @@
USING: accessors arrays assocs combinators
combinators.short-circuit fry kernel locals
make math sequences
compiler.cfg.rpo
compiler.cfg.liveness
compiler.cfg.utilities
compiler.cfg.instructions
compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.mapping compiler.cfg.liveness ;
compiler.cfg.linear-scan.mapping ;
IN: compiler.cfg.linear-scan.resolve
: add-mapping ( from to reg-class -- )
@ -43,5 +45,5 @@ IN: compiler.cfg.linear-scan.resolve
: resolve-block-data-flow ( bb -- )
dup successors>> [ resolve-edge-data-flow ] with each ;
: resolve-data-flow ( rpo -- )
[ resolve-block-data-flow ] each ;
: resolve-data-flow ( cfg -- )
[ resolve-block-data-flow ] each-basic-block ;

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

@ -4,7 +4,6 @@ USING: kernel math accessors sequences namespaces make
combinators assocs arrays locals cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.liveness
compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.cfg.instructions ;

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

@ -1 +0,0 @@
Slava Pestov

43
basis/compiler/cfg/liveness/liveness-tests.factor
View File

@ -1,15 +1,38 @@
USING: compiler.cfg compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.liveness accessors tools.test cpu.architecture ;
USING: compiler.cfg.liveness compiler.cfg.debugger
compiler.cfg.instructions compiler.cfg.predecessors
compiler.cfg.registers compiler.cfg cpu.architecture
accessors namespaces sequences kernel tools.test ;
IN: compiler.cfg.liveness.tests
! Sanity check...
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##replace f V int-regs 1 D 1 }
T{ ##peek f V int-regs 1 D 1 }
} 1 test-bb
V{
T{ ##replace f V int-regs 2 D 0 }
} 2 test-bb
V{
T{ ##replace f V int-regs 3 D 0 }
} 3 test-bb
1 get 2 get 3 get V{ } 2sequence >>successors drop
cfg new 1 get >>entry
compute-predecessors
compute-live-sets
[
H{
{ "A" H{ { V int-regs 1 V int-regs 1 } { V int-regs 4 V int-regs 4 } } }
{ "B" H{ { V int-regs 3 V int-regs 3 } { V int-regs 2 V int-regs 2 } } }
{ V int-regs 1 V int-regs 1 }
{ V int-regs 2 V int-regs 2 }
{ V int-regs 3 V int-regs 3 }
}
] [
<basic-block> V{
T{ ##phi f V int-regs 0 { { "A" V int-regs 1 } { "B" V int-regs 2 } } }
T{ ##phi f V int-regs 1 { { "B" V int-regs 3 } { "A" V int-regs 4 } } }
} >>instructions compute-phi-live-in
] unit-test
]
[ 1 get live-in ]
unit-test

90
basis/compiler/cfg/liveness/liveness.factor
View File

@ -1,82 +1,26 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces deques accessors sets sequences assocs fry
hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.rpo ;
USING: kernel accessors assocs sequences sets
compiler.cfg.def-use compiler.cfg.dataflow-analysis
compiler.cfg.instructions ;
IN: compiler.cfg.liveness
! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis
! See http://en.wikipedia.org/wiki/Liveness_analysis
! Do not run after SSA construction
! Assoc mapping basic blocks to sets of vregs
SYMBOL: live-ins
BACKWARD-ANALYSIS: live
: live-in ( basic-block -- set ) live-ins get at ;
: transfer-liveness ( live-set instructions -- live-set' )
[ clone ] [ <reversed> ] bi* [
[ uses-vregs [ over conjoin ] each ]
[ defs-vregs [ over delete-at ] each ] bi
] each ;
! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
! is in conrrespondence with a predecessor
SYMBOL: phi-live-ins
: local-live-in ( instructions -- live-set )
[ ##phi? not ] filter [ H{ } ] dip transfer-liveness keys ;
: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
M: live-analysis transfer-set
drop instructions>> transfer-liveness ;
! 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 ;
: conjoin-at ( value key assoc -- )
[ dupd ?set-at ] change-at ;
: compute-phi-live-in ( basic-block -- phi-live-in )
instructions>> [ ##phi? ] filter [ f ] [
H{ } clone [
'[ inputs>> [ swap _ conjoin-at ] assoc-each ] each
] keep
] 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 ;
M: live-analysis join-sets
drop assoc-combine ;

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

@ -1 +0,0 @@
Slava Pestov

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

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

3
basis/compiler/cfg/mr/mr.factor
View File

@ -1,13 +1,12 @@
! 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.gc-checks compiler.cfg.linear-scan
compiler.cfg.build-stack-frame compiler.cfg.rpo ;
IN: compiler.cfg.mr
: build-mr ( cfg -- mr )
convert-two-operand
compute-liveness
insert-gc-checks
linear-scan
flatten-cfg

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

@ -11,7 +11,6 @@ compiler.cfg.alias-analysis
compiler.cfg.value-numbering
compiler.cfg.dce
compiler.cfg.write-barrier
compiler.cfg.liveness
compiler.cfg.rpo
compiler.cfg.phi-elimination
compiler.cfg.checker ;
@ -35,7 +34,6 @@ SYMBOL: check-optimizer?
join-blocks
compute-predecessors
stack-analysis
compute-liveness
alias-analysis
value-numbering
compute-predecessors

23
basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor
View File

@ -36,27 +36,20 @@ V{
test-diamond
3 vreg-counter set-global
[ ] [ cfg new 0 get >>entry eliminate-phis drop ] unit-test
[let | n! [ f ] |
[ ] [ 2 get successors>> first instructions>> first dst>> n>> n! ] unit-test
[ t ] [
T{ ##copy f V int-regs n V int-regs 1 }
2 get successors>> first instructions>> first =
[ T{ ##copy f V int-regs 4 V int-regs 1 } ] [
2 get successors>> first instructions>> first
] unit-test
[ t ] [
T{ ##copy f V int-regs n V int-regs 2 }
3 get successors>> first instructions>> first =
[ T{ ##copy f V int-regs 4 V int-regs 2 } ] [
3 get successors>> first instructions>> first
] unit-test
[ t ] [
T{ ##copy f V int-regs 3 V int-regs n }
4 get instructions>> first =
[ T{ ##copy f V int-regs 3 V int-regs 4 } ] [
4 get instructions>> first
] unit-test
]
[ 3 ] [ 4 get instructions>> length ] unit-test

12
basis/compiler/cfg/registers/registers.factor
View File

@ -1,11 +1,17 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces kernel arrays parser ;
USING: accessors namespaces kernel arrays parser math math.order ;
IN: compiler.cfg.registers
! Virtual registers, used by CFG and machine IRs
TUPLE: vreg { reg-class read-only } { n read-only } ;
TUPLE: vreg { reg-class read-only } { n fixnum read-only } ;
M: vreg equal? over vreg? [ [ n>> ] bi@ eq? ] [ 2drop f ] if ;
M: vreg hashcode* nip n>> ;
SYMBOL: vreg-counter
: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
! Stack locations -- 'n' is an index starting from the top of the stack

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

@ -6,7 +6,7 @@ IN: compiler.cfg.renaming
SYMBOL: renamings
: rename-value ( vreg -- vreg' ) renamings get at ;
: rename-value ( vreg -- vreg' ) renamings get ?at drop ;
GENERIC: rename-insn-defs ( insn -- )
@ -14,6 +14,14 @@ M: ##flushable rename-insn-defs
[ rename-value ] change-dst
drop ;
M: ##fixnum-overflow rename-insn-defs
[ rename-value ] change-dst
drop ;
M: _fixnum-overflow rename-insn-defs
[ rename-value ] change-dst
drop ;
M: insn rename-insn-defs drop ;
GENERIC: rename-insn-uses ( insn -- )

7
basis/compiler/cfg/rpo/rpo.factor
View File

@ -33,3 +33,10 @@ SYMBOL: visited
: each-basic-block ( cfg quot -- )
[ reverse-post-order ] dip each ; inline
: optimize-basic-block ( bb quot -- )
[ drop basic-block set ]
[ change-instructions drop ] 2bi ; inline
: local-optimization ( cfg quot: ( insns -- insns' ) -- cfg' )
dupd '[ _ optimize-basic-block ] each-basic-block ; inline

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

@ -0,0 +1,113 @@
USING: accessors compiler.cfg compiler.cfg.debugger
compiler.cfg.dominance compiler.cfg.instructions
compiler.cfg.predecessors compiler.cfg.ssa assocs
compiler.cfg.registers cpu.architecture kernel namespaces sequences
tools.test vectors ;
IN: compiler.cfg.ssa.tests
: reset-counters ( -- )
! Reset counters so that results are deterministic w.r.t. hash order
0 vreg-counter set-global
0 basic-block set-global ;
reset-counters
V{
T{ ##load-immediate f V int-regs 1 100 }
T{ ##add-imm f V int-regs 2 V int-regs 1 50 }
T{ ##add-imm f V int-regs 2 V int-regs 2 10 }
T{ ##branch }
} 0 test-bb
V{
T{ ##load-immediate f V int-regs 3 3 }
T{ ##branch }
} 1 test-bb
V{
T{ ##load-immediate f V int-regs 3 4 }
T{ ##branch }
} 2 test-bb
V{
T{ ##replace f V int-regs 3 D 0 }
T{ ##return }
} 3 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
1 get 3 get 1vector >>successors drop
2 get 3 get 1vector >>successors drop
: test-ssa ( -- )
cfg new 0 get >>entry
compute-predecessors
construct-ssa
drop ;
[ ] [ test-ssa ] unit-test
[
V{
T{ ##load-immediate f V int-regs 1 100 }
T{ ##add-imm f V int-regs 2 V int-regs 1 50 }
T{ ##add-imm f V int-regs 3 V int-regs 2 10 }
T{ ##branch }
}
] [ 0 get instructions>> ] unit-test
[
V{
T{ ##load-immediate f V int-regs 4 3 }
T{ ##branch }
}
] [ 1 get instructions>> ] unit-test
[
V{
T{ ##load-immediate f V int-regs 5 4 }
T{ ##branch }
}
] [ 2 get instructions>> ] unit-test
: clean-up-phis ( insns -- insns' )
[ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ;
[
V{
T{ ##phi f V int-regs 6 H{ { 1 V int-regs 4 } { 2 V int-regs 5 } } }
T{ ##replace f V int-regs 6 D 0 }
T{ ##return }
}
] [
3 get instructions>>
clean-up-phis
] unit-test
reset-counters
V{ } 0 test-bb
V{ } 1 test-bb
V{ T{ ##peek f V int-regs 0 D 0 } } 2 test-bb
V{ T{ ##peek f V int-regs 0 D 0 } } 3 test-bb
V{ T{ ##replace f V int-regs 0 D 0 } } 4 test-bb
V{ } 5 test-bb
V{ } 6 test-bb
0 get 1 get 5 get V{ } 2sequence >>successors drop
1 get 2 get 3 get V{ } 2sequence >>successors drop
2 get 4 get 1vector >>successors drop
3 get 4 get 1vector >>successors drop
4 get 6 get 1vector >>successors drop
5 get 6 get 1vector >>successors drop
[ ] [ test-ssa ] unit-test
[
V{
T{ ##phi f V int-regs 3 H{ { 2 V int-regs 1 } { 3 V int-regs 2 } } }
T{ ##replace f V int-regs 3 D 0 }
}
] [
4 get instructions>>
clean-up-phis
] unit-test

131
basis/compiler/cfg/ssa/ssa.factor Normal file
View File

@ -0,0 +1,131 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel accessors sequences fry assocs
sets math combinators
compiler.cfg
compiler.cfg.rpo
compiler.cfg.def-use
compiler.cfg.renaming
compiler.cfg.liveness
compiler.cfg.registers
compiler.cfg.dominance
compiler.cfg.instructions ;
IN: compiler.cfg.ssa
! SSA construction. Predecessors must be computed first.
! This is the classical algorithm based on dominance frontiers, except
! we consult liveness information to build pruned SSA:
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.25.8240
! Eventually might be worth trying something fancier:
! http://portal.acm.org/citation.cfm?id=1065887.1065890
<PRIVATE
! Maps vreg to sequence of basic blocks
SYMBOL: defs
! Maps basic blocks to sequences of vregs
SYMBOL: inserting-phi-nodes
: compute-defs ( cfg -- )
H{ } clone dup defs set
'[
dup instructions>> [
defs-vregs [
_ conjoin-at
] with each
] with each
] each-basic-block ;
: insert-phi-node-later ( vreg bb -- )
2dup live-in key? [
[ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
inserting-phi-nodes get push-at
] [ 2drop ] if ;
: compute-phi-nodes-for ( vreg bbs -- )
keys dup length 2 >= [
iterated-dom-frontier [
insert-phi-node-later
] with each
] [ 2drop ] if ;
: compute-phi-nodes ( -- )
H{ } clone inserting-phi-nodes set
defs get [ compute-phi-nodes-for ] assoc-each ;
: insert-phi-nodes-in ( phis bb -- )
[ append ] change-instructions drop ;
: insert-phi-nodes ( -- )
inserting-phi-nodes get [ swap insert-phi-nodes-in ] assoc-each ;
SYMBOLS: stacks originals ;
: init-renaming ( -- )
H{ } clone stacks set
H{ } clone originals set ;
: gen-name ( vreg -- vreg' )
[ reg-class>> next-vreg ] keep
[ stacks get push-at ]
[ swap originals get set-at ]
[ drop ]
2tri ;
: top-name ( vreg -- vreg' )
stacks get at last ;
GENERIC: rename-insn ( insn -- )
M: insn rename-insn
[ dup uses-vregs [ dup top-name ] { } map>assoc renamings set rename-insn-uses ]
[ dup defs-vregs [ dup gen-name ] { } map>assoc renamings set rename-insn-defs ]
bi ;
M: ##phi rename-insn
dup defs-vregs [ dup gen-name ] { } map>assoc renamings set rename-insn-defs ;
: rename-insns ( bb -- )
instructions>> [ rename-insn ] each ;
: rename-successor-phi ( phi bb -- )
swap inputs>> [ top-name ] change-at ;
: rename-successor-phis ( succ bb -- )
[ inserting-phi-nodes get at ] dip
'[ _ rename-successor-phi ] each ;
: rename-successors-phis ( bb -- )
[ successors>> ] keep '[ _ rename-successor-phis ] each ;
: pop-stacks ( bb -- )
instructions>> [
defs-vregs originals get stacks get
'[ _ at _ at pop* ] each
] each ;
: rename-in-block ( bb -- )
{
[ rename-insns ]
[ rename-successors-phis ]
[ dom-children [ rename-in-block ] each ]
[ pop-stacks ]
} cleave ;
: rename ( cfg -- )
init-renaming
entry>> rename-in-block ;
PRIVATE>
: construct-ssa ( cfg -- cfg' )
{
[ ]
[ compute-live-sets ]
[ compute-dominance ]
[ compute-defs compute-phi-nodes insert-phi-nodes ]
[ rename ]
} cleave ;

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

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences make compiler.cfg.instructions
compiler.cfg.local cpu.architecture ;
compiler.cfg.rpo cpu.architecture ;
IN: compiler.cfg.two-operand
! On x86, instructions take the form x = x op y
@ -54,7 +54,6 @@ M: insn convert-two-operand* , ;
: convert-two-operand ( cfg -- cfg' )
two-operand? [
[ drop ]
[ [ [ convert-two-operand* ] each ] V{ } make ]
local-optimization
] when ;

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

@ -6,7 +6,6 @@ compiler.cfg.value-numbering.graph ;
IN: compiler.cfg.value-numbering.expressions
! Referentially-transparent expressions
TUPLE: expr op ;
TUPLE: unary-expr < expr in ;
TUPLE: binary-expr < expr in1 in2 ;
TUPLE: commutative-expr < binary-expr ;
@ -37,17 +36,6 @@ M: reference-expr equal?
} cond
] [ 2drop f ] if ;
! Expressions whose values are inputs to the basic block. We
! can eliminate a second computation having the same 'n' as
! the first one; we can also eliminate input-exprs whose
! result is not used.
TUPLE: input-expr < expr n ;
SYMBOL: input-expr-counter
: next-input-expr ( class -- expr )
input-expr-counter [ dup 1 + ] change input-expr boa ;
: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
GENERIC: >expr ( insn -- expr )
@ -97,7 +85,7 @@ M: ##compare-imm >expr compare-imm>expr ;
M: ##compare-float >expr compare>expr ;
M: ##flushable >expr class next-input-expr ;
M: ##flushable >expr drop next-input-expr ;
: init-expressions ( -- )
0 input-expr-counter set ;

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

@ -10,13 +10,24 @@ SYMBOL: vn-counter
! biassoc mapping expressions to value numbers
SYMBOL: exprs>vns
TUPLE: expr op ;
: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
: vn>expr ( vn -- expr ) exprs>vns get value-at ;
! Expressions whose values are inputs to the basic block.
TUPLE: input-expr < expr n ;
SYMBOL: input-expr-counter
: next-input-expr ( -- expr )
f input-expr-counter counter input-expr boa ;
SYMBOL: vregs>vns
: vreg>vn ( vreg -- vn ) vregs>vns get at ;
: vreg>vn ( vreg -- vn )
vregs>vns get [ drop next-input-expr expr>vn ] cache ;
: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;

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

@ -3,7 +3,7 @@ USING: compiler.cfg.value-numbering compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
cpu.architecture tools.test kernel math combinators.short-circuit
accessors sequences compiler.cfg.predecessors locals
compiler.cfg.phi-elimination compiler.cfg.dce compiler.cfg.liveness
compiler.cfg.phi-elimination compiler.cfg.dce
compiler.cfg assocs vectors arrays layouts namespaces ;
: trim-temps ( insns -- insns )
@ -15,10 +15,6 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
} 1|| [ f >>temp ] when
] map ;
: test-value-numbering ( insns -- insns )
{ } init-value-numbering
value-numbering-step ;
! Folding constants together
[
{
@ -33,7 +29,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##load-reference f V int-regs 1 -0.0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##replace f V int-regs 1 D 1 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -49,7 +45,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##load-reference f V int-regs 1 0.0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##replace f V int-regs 1 D 1 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -65,7 +61,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##load-reference f V int-regs 1 t }
T{ ##replace f V int-regs 0 D 0 }
T{ ##replace f V int-regs 1 D 1 }
} test-value-numbering
} value-numbering-step
] unit-test
! Copy propagation
@ -80,7 +76,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 45 D 1 }
T{ ##copy f V int-regs 48 V int-regs 45 }
T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
} test-value-numbering
} value-numbering-step
] unit-test
! Compare propagation
@ -99,7 +95,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
T{ ##replace f V int-regs 6 D 0 }
} test-value-numbering trim-temps
} value-numbering-step trim-temps
] unit-test
[
@ -117,7 +113,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
T{ ##replace f V int-regs 6 D 0 }
} test-value-numbering trim-temps
} value-numbering-step trim-temps
] unit-test
[
@ -139,7 +135,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
T{ ##replace f V int-regs 14 D 0 }
} test-value-numbering trim-temps
} value-numbering-step trim-temps
] unit-test
[
@ -155,7 +151,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
} test-value-numbering trim-temps
} value-numbering-step trim-temps
] unit-test
! Immediate operand conversion
@ -170,7 +166,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -184,7 +180,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -198,7 +194,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -210,7 +206,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
{
T{ ##peek f V int-regs 0 D 0 }
T{ ##sub f V int-regs 1 V int-regs 0 V int-regs 0 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -224,7 +220,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -238,7 +234,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -250,7 +246,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
{
T{ ##peek f V int-regs 1 D 0 }
T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -264,7 +260,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -278,7 +274,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -292,7 +288,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -306,7 +302,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -320,7 +316,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -334,7 +330,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -348,7 +344,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##compare f V int-regs 2 V int-regs 0 V int-regs 1 cc<= }
} test-value-numbering trim-temps
} value-numbering-step trim-temps
] unit-test
[
@ -362,7 +358,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##compare f V int-regs 2 V int-regs 1 V int-regs 0 cc<= }
} test-value-numbering trim-temps
} value-numbering-step trim-temps
] unit-test
[
@ -376,7 +372,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##compare-branch f V int-regs 0 V int-regs 1 cc<= }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -390,7 +386,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##compare-branch f V int-regs 1 V int-regs 0 cc<= }
} test-value-numbering trim-temps
} value-numbering-step trim-temps
] unit-test
! Reassociation
@ -409,7 +405,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
T{ ##load-immediate f V int-regs 3 50 }
T{ ##add f V int-regs 4 V int-regs 2 V int-regs 3 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -427,7 +423,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 }
T{ ##load-immediate f V int-regs 3 50 }
T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -445,7 +441,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
T{ ##load-immediate f V int-regs 3 50 }
T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -463,7 +459,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 }
T{ ##load-immediate f V int-regs 3 50 }
T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -481,7 +477,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
T{ ##load-immediate f V int-regs 3 50 }
T{ ##mul f V int-regs 4 V int-regs 2 V int-regs 3 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -499,7 +495,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 }
T{ ##load-immediate f V int-regs 3 50 }
T{ ##mul f V int-regs 4 V int-regs 3 V int-regs 2 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -517,7 +513,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 }
T{ ##load-immediate f V int-regs 3 50 }
T{ ##and f V int-regs 4 V int-regs 2 V int-regs 3 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -535,7 +531,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 }
T{ ##load-immediate f V int-regs 3 50 }
T{ ##and f V int-regs 4 V int-regs 3 V int-regs 2 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -553,7 +549,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 }
T{ ##load-immediate f V int-regs 3 50 }
T{ ##or f V int-regs 4 V int-regs 2 V int-regs 3 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -571,7 +567,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 }
T{ ##load-immediate f V int-regs 3 50 }
T{ ##or f V int-regs 4 V int-regs 3 V int-regs 2 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -589,7 +585,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 }
T{ ##load-immediate f V int-regs 3 50 }
T{ ##xor f V int-regs 4 V int-regs 2 V int-regs 3 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -607,7 +603,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 }
T{ ##load-immediate f V int-regs 3 50 }
T{ ##xor f V int-regs 4 V int-regs 3 V int-regs 2 }
} test-value-numbering
} value-numbering-step
] unit-test
! Simplification
@ -626,7 +622,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
T{ ##replace f V int-regs 3 D 0 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -644,7 +640,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
T{ ##sub f V int-regs 3 V int-regs 0 V int-regs 2 }
T{ ##replace f V int-regs 3 D 0 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -662,7 +658,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
T{ ##or f V int-regs 3 V int-regs 0 V int-regs 2 }
T{ ##replace f V int-regs 3 D 0 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -680,7 +676,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
T{ ##xor f V int-regs 3 V int-regs 0 V int-regs 2 }
T{ ##replace f V int-regs 3 D 0 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -696,7 +692,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##load-immediate f V int-regs 1 1 }
T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
T{ ##replace f V int-regs 2 D 0 }
} test-value-numbering
} value-numbering-step
] unit-test
! Constant folding
@ -713,7 +709,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##load-immediate f V int-regs 1 1 }
T{ ##load-immediate f V int-regs 2 3 }
T{ ##add f V int-regs 3 V int-regs 1 V int-regs 2 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -729,7 +725,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##load-immediate f V int-regs 1 1 }
T{ ##load-immediate f V int-regs 2 3 }
T{ ##sub f V int-regs 3 V int-regs 1 V int-regs 2 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -745,7 +741,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##load-immediate f V int-regs 1 2 }
T{ ##load-immediate f V int-regs 2 3 }
T{ ##mul f V int-regs 3 V int-regs 1 V int-regs 2 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -761,7 +757,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##load-immediate f V int-regs 1 2 }
T{ ##load-immediate f V int-regs 2 1 }
T{ ##and f V int-regs 3 V int-regs 1 V int-regs 2 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -777,7 +773,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##load-immediate f V int-regs 1 2 }
T{ ##load-immediate f V int-regs 2 1 }
T{ ##or f V int-regs 3 V int-regs 1 V int-regs 2 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -793,7 +789,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##load-immediate f V int-regs 1 2 }
T{ ##load-immediate f V int-regs 2 3 }
T{ ##xor f V int-regs 3 V int-regs 1 V int-regs 2 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -807,7 +803,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 1 }
T{ ##shl-imm f V int-regs 3 V int-regs 1 3 }
} test-value-numbering
} value-numbering-step
] unit-test
cell 8 = [
@ -822,7 +818,7 @@ cell 8 = [
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 -1 }
T{ ##shr-imm f V int-regs 3 V int-regs 1 16 }
} test-value-numbering
} value-numbering-step
] unit-test
] when
@ -837,7 +833,7 @@ cell 8 = [
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 -8 }
T{ ##sar-imm f V int-regs 3 V int-regs 1 1 }
} test-value-numbering
} value-numbering-step
] unit-test
cell 8 = [
@ -854,7 +850,7 @@ cell 8 = [
T{ ##load-immediate f V int-regs 1 65536 }
T{ ##shl-imm f V int-regs 2 V int-regs 1 31 }
T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -868,7 +864,7 @@ cell 8 = [
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 2 140737488355328 }
T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -884,7 +880,7 @@ cell 8 = [
T{ ##load-immediate f V int-regs 2 2147483647 }
T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 }
} test-value-numbering
} value-numbering-step
] unit-test
] when
@ -900,7 +896,7 @@ cell 8 = [
T{ ##load-immediate f V int-regs 1 1 }
T{ ##load-immediate f V int-regs 2 2 }
T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc= }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -914,7 +910,7 @@ cell 8 = [
T{ ##load-immediate f V int-regs 1 1 }
T{ ##load-immediate f V int-regs 2 2 }
T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc/= }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -928,7 +924,7 @@ cell 8 = [
T{ ##load-immediate f V int-regs 1 1 }
T{ ##load-immediate f V int-regs 2 2 }
T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc< }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -942,7 +938,7 @@ cell 8 = [
T{ ##load-immediate f V int-regs 1 1 }
T{ ##load-immediate f V int-regs 2 2 }
T{ ##compare f V int-regs 3 V int-regs 2 V int-regs 1 cc< }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -954,7 +950,7 @@ cell 8 = [
{
T{ ##peek f V int-regs 0 D 0 }
T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc< }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -966,7 +962,7 @@ cell 8 = [
{
T{ ##peek f V int-regs 0 D 0 }
T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -978,7 +974,7 @@ cell 8 = [
{
T{ ##peek f V int-regs 0 D 0 }
T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc> }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -990,7 +986,7 @@ cell 8 = [
{
T{ ##peek f V int-regs 0 D 0 }
T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc>= }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -1002,7 +998,7 @@ cell 8 = [
{
T{ ##peek f V int-regs 0 D 0 }
T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc/= }
} test-value-numbering
} value-numbering-step
] unit-test
[
@ -1014,12 +1010,12 @@ cell 8 = [
{
T{ ##peek f V int-regs 0 D 0 }
T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc= }
} test-value-numbering
} value-numbering-step
] unit-test
: test-branch-folding ( insns -- insns' n )
<basic-block>
[ V{ 0 1 } clone >>successors basic-block set test-value-numbering ] keep
[ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
successors>> first ;
[
@ -1208,7 +1204,6 @@ test-diamond
[ ] [
cfg new 0 get >>entry
compute-liveness
value-numbering
compute-predecessors
eliminate-phis drop
@ -1218,17 +1213,6 @@ test-diamond
[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
[let | n! [ f ] |
[ ] [ 2 get successors>> first instructions>> first src>> n>> n! ] unit-test
[ t ] [
T{ ##copy f V int-regs n V int-regs 2 }
3 get successors>> first instructions>> first =
] unit-test
]
[ 3 ] [ 4 get instructions>> length ] unit-test
V{
@ -1264,7 +1248,6 @@ test-diamond
[ ] [
cfg new 0 get >>entry
compute-predecessors
compute-liveness
value-numbering
compute-predecessors
eliminate-dead-code
@ -1335,7 +1318,7 @@ V{
[ ] [
cfg new 0 get >>entry
compute-liveness value-numbering eliminate-dead-code drop
value-numbering eliminate-dead-code drop
] unit-test
[ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test

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

@ -3,8 +3,7 @@
USING: namespaces assocs biassocs classes kernel math accessors
sorting sets sequences fry
compiler.cfg
compiler.cfg.local
compiler.cfg.liveness
compiler.cfg.rpo
compiler.cfg.renaming
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions
@ -13,15 +12,6 @@ compiler.cfg.value-numbering.rewrite ;
IN: compiler.cfg.value-numbering
! Local value numbering. Predecessors must be recomputed after this
: number-input-values ( live-in -- )
[ [ f next-input-expr simplify ] dip set-vn ] each ;
: init-value-numbering ( live-in -- )
init-value-graph
init-expressions
number-input-values ;
: vreg>vreg-mapping ( -- assoc )
vregs>vns get [ keys ] keep
'[ dup _ [ at ] [ value-at ] bi ] H{ } map>assoc ;
@ -32,8 +22,10 @@ IN: compiler.cfg.value-numbering
] with-variable ;
: value-numbering-step ( insns -- insns' )
[ rewrite ] map dup rename-uses ;
init-value-graph
init-expressions
[ rewrite ] map
dup rename-uses ;
: value-numbering ( cfg -- cfg' )
[ init-value-numbering ] [ value-numbering-step ] local-optimization
cfg-changed ;
[ value-numbering-step ] local-optimization cfg-changed ;

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences locals
compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop
compiler.cfg.liveness compiler.cfg.local ;
compiler.cfg.rpo ;
IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits.
@ -43,4 +43,4 @@ M: insn eliminate-write-barrier ;
[ eliminate-write-barrier ] map sift ;
: eliminate-write-barriers ( cfg -- cfg' )
[ drop ] [ write-barriers-step ] local-optimization ;
[ write-barriers-step ] local-optimization ;

22
basis/functors/functors.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.mixin classes.parser
classes.tuple classes.tuple.parser combinators effects
effects.parser fry generic generic.parser generic.standard
interpolate io.streams.string kernel lexer locals.parser
locals.rewrite.closures locals.types make namespaces parser
quotations sequences vocabs.parser words words.symbol ;
USING: accessors arrays classes.mixin classes.parser classes.singleton
classes.tuple classes.tuple.parser combinators effects effects.parser
fry generic generic.parser generic.standard interpolate
io.streams.string kernel lexer locals.parser locals.rewrite.closures
locals.types make namespaces parser quotations sequences vocabs.parser
words words.symbol ;
IN: functors
! This is a hack
@ -71,6 +71,14 @@ SYNTAX: `TUPLE:
} case
\ define-tuple-class parsed ;
SYNTAX: `SINGLETON:
scan-param parsed
\ define-singleton-class parsed ;
SYNTAX: `MIXIN:
scan-param parsed
\ define-mixin-class parsed ;
SYNTAX: `M:
scan-param parsed
scan-param parsed
@ -134,6 +142,8 @@ DEFER: ;FUNCTOR delimiter
: functor-words ( -- assoc )
H{
{ "TUPLE:" POSTPONE: `TUPLE: }
{ "SINGLETON:" POSTPONE: `SINGLETON: }
{ "MIXIN:" POSTPONE: `MIXIN: }
{ "M:" POSTPONE: `M: }
{ "C:" POSTPONE: `C: }
{ ":" POSTPONE: `: }

4
basis/unix/types/freebsd/freebsd.factor
View File

@ -1,4 +1,4 @@
USING: alien.syntax ;
USING: alien.syntax alien.c-types ;
IN: unix.types
@ -22,3 +22,5 @@ TYPEDEF: __uint32_t fflags_t
TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t
ALIAS: <time_t> <int>

4
basis/unix/types/linux/linux.factor
View File

@ -1,4 +1,4 @@
USING: alien.syntax ;
USING: alien.syntax alien.c-types ;
IN: unix.types
TYPEDEF: ulonglong __uquad_type
@ -31,3 +31,5 @@ TYPEDEF: ulonglong __fsblkcnt64_t
TYPEDEF: ulonglong __fsfilcnt64_t
TYPEDEF: ulonglong ino64_t
TYPEDEF: ulonglong off64_t
ALIAS: <time_t> <long>

4
basis/unix/types/macosx/macosx.factor
View File

@ -1,4 +1,4 @@
USING: alien.syntax ;
USING: alien.syntax alien.c-types ;
IN: unix.types
! Darwin 9.1.0
@ -21,3 +21,5 @@ TYPEDEF: __int32_t blksize_t
TYPEDEF: long ssize_t
TYPEDEF: __int32_t pid_t
TYPEDEF: long time_t
ALIAS: <time_t> <long>

4
basis/unix/types/netbsd/netbsd.factor
View File

@ -1,4 +1,4 @@
USING: alien.syntax combinators layouts vocabs.loader ;
USING: alien.syntax alien.c-types combinators layouts vocabs.loader ;
IN: unix.types
! NetBSD 4.0
@ -17,6 +17,8 @@ TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t
ALIAS: <time_t> <int>
cell-bits {
{ 32 [ "unix.types.netbsd.32" require ] }
{ 64 [ "unix.types.netbsd.64" require ] }

4
basis/unix/types/openbsd/openbsd.factor
View File

@ -1,4 +1,4 @@
USING: alien.syntax ;
USING: alien.syntax alien.c-types ;
IN: unix.types
! OpenBSD 4.2
@ -17,3 +17,5 @@ TYPEDEF: __uint32_t fflags_t
TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t
ALIAS: <time_t> <int>

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

@ -134,3 +134,19 @@ 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
[ H{ { 1 2 } { 2 3 } } ] [
{
H{ { 1 3 } }
H{ { 2 3 } }
H{ { 1 2 } }
} assoc-combine
] unit-test
[ H{ { 1 7 } } ] [
{
H{ { 1 2 } { 2 4 } { 5 6 } }
H{ { 1 3 } { 2 5 } }
H{ { 1 7 } { 5 6 } }
} assoc-refine
] unit-test

3
core/assocs/assocs.factor
View File

@ -129,6 +129,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: assoc-combine ( seq -- union )
H{ } clone [ dupd update ] reduce ;
: assoc-refine ( seq -- assoc )
[ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
: assoc-diff ( assoc1 assoc2 -- diff )
[ nip key? not ] curry assoc-filter ;

5
core/sets/sets-docs.factor
View File

@ -23,6 +23,7 @@ $nl
"Adding elements to sets:"
{ $subsection adjoin }
{ $subsection conjoin }
{ $subsection conjoin-at }
{ $see-also member? memq? any? all? "assocs-sets" } ;
ABOUT: "sets"
@ -54,6 +55,10 @@ HELP: conjoin
}
{ $side-effects "assoc" } ;
HELP: conjoin-at
{ $values { "value" object } { "key" object } { "assoc" assoc } }
{ $description "Adds " { $snippet "value" } " to the set stored at " { $snippet "key" } " of " { $snippet "assoc" } "." } ;
HELP: unique
{ $values { "seq" "a sequence" } { "assoc" assoc } }
{ $description "Outputs a new assoc where the keys and values are equal." }

3
core/sets/sets.factor
View File

@ -7,6 +7,9 @@ IN: sets
: conjoin ( elt assoc -- ) dupd set-at ;
: conjoin-at ( value key assoc -- )
[ dupd ?set-at ] change-at ;
: (prune) ( elt hash vec -- )
3dup drop key? [ 3drop ] [
[ drop conjoin ] [ nip push ] 3bi

28
extra/sequences/abbrev/abbrev-docs.factor Normal file
View File

@ -0,0 +1,28 @@
! Copyright (C) 2009 Maximilian Lupke.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs help.markup help.syntax sequences ;
IN: sequences.abbrev
HELP: abbrev
{ $values
{ "seqs" sequence }
{ "assoc" assoc }
}
{ $description "Calculates an assoc of { prefix sequence } pairs with prefix being an prefix of each element of sequence for each element in " { $snippet "seqs" } "." } ;
HELP: unique-abbrev
{ $values
{ "seqs" sequence }
{ "assoc" assoc }
}
{ $description "Calculates an assoc of { prefix { sequence } } pairs with prefix being an unambiguous prefix of sequence in seqs." } ;
ARTICLE: "sequences.abbrev" "Examples of abbrev usage"
"It is probably easiest to just run examples to understand abbrev."
{ $code
"{ \"hello\" \"help\" } abbrev"
"{ \"hello\" \"help\" } unique-abbrev"
}
;
ABOUT: "sequences.abbrev"

26
extra/sequences/abbrev/abbrev-tests.factor Normal file
View File

@ -0,0 +1,26 @@
USING: assocs sequences.abbrev tools.test ;
IN: sequences.abbrev.tests
[ { "hello" "help" } ] [
"he" { "apple" "hello" "help" } abbrev at
] unit-test
[ f ] [
"he" { "apple" "hello" "help" } unique-abbrev at
] unit-test
[ { "apple" } ] [
"a" { "apple" "hello" "help" } abbrev at
] unit-test
[ { "apple" } ] [
"a" { "apple" "hello" "help" } unique-abbrev at
] unit-test
[ f ] [
"a" { "hello" "help" } abbrev at
] unit-test
[ f ] [
"a" { "hello" "help" } unique-abbrev at
] unit-test

23
extra/sequences/abbrev/abbrev.factor Normal file
View File

@ -0,0 +1,23 @@
! Copyright (C) 2009 Maximilian Lupke.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs fry kernel math.ranges sequences ;
IN: sequences.abbrev
<PRIVATE
: prefixes ( seq -- prefixes )
dup length [1,b] [ head ] with map ;
: (abbrev) ( seq -- assoc )
[ prefixes ] keep 1array '[ _ ] H{ } map>assoc ;
: assoc-merge ( assoc1 assoc2 -- assoc3 )
tuck '[ over _ at dup [ append ] [ drop ] if ] assoc-map assoc-union ;
PRIVATE>
: abbrev ( seqs -- assoc )
[ (abbrev) ] map H{ } [ assoc-merge ] reduce ;
: unique-abbrev ( seqs -- assoc )
abbrev [ nip length 1 = ] assoc-filter ;

1
extra/sequences/abbrev/authors.txt Normal file
View File

@ -0,0 +1 @@
Maximilian Lupke