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

Merge branch 'dcn' of git://factorcode.org/git/factor into dcn

db4
Slava Pestov 2009-07-24 17:12:20 -05:00
parent 4bc0741a19 4624af75f4
commit 4fcd05cef7
106 changed files with 1960 additions and 2564 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
basis/alien/parser/parser.factor
View File

@ -1,18 +1,30 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs effects grouping kernel
parser sequences splitting words fry locals lexer namespaces ;
parser sequences splitting words fry locals lexer namespaces
summary math ;
IN: alien.parser
: normalize-c-arg ( type name -- type' name' )
[ length ]
[
[ CHAR: * = ] trim-head
[ length - CHAR: * <array> append ] keep
] bi ;
: parse-arglist ( parameters return -- types effect )
[ 2 group unzip [ "," ?tail drop ] map ]
[
2 group [ first2 normalize-c-arg 2array ] map
unzip [ "," ?tail drop ] map
]
[ [ { } ] [ 1array ] if-void ]
bi* <effect> ;
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
:: make-function ( return library function parameters -- word quot effect )
:: make-function ( return! library function! parameters -- word quot effect )
return function normalize-c-arg function! return!
function create-in dup reset-generic
return library function
parameters return parse-arglist [ function-quot ] dip ;

2
basis/cairo/ffi/ffi.factor
View File

@ -896,7 +896,7 @@ FUNCTION: cairo_status_t
cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t** surface ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;

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 ;

17
basis/compiler/cfg/branch-splitting/branch-splitting.factor
View File

@ -6,18 +6,8 @@ compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.branch-splitting
: clone-renamings ( insns -- assoc )
[ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ;
: clone-instructions ( insns -- insns' )
dup clone-renamings renamings [
[
clone
dup rename-insn-defs
dup rename-insn-uses
dup fresh-insn-temps
] map
] with-variable ;
[ clone dup fresh-insn-temps ] map ;
: clone-basic-block ( bb -- bb' )
! The new block gets the same RPO number as the old one.
@ -62,10 +52,7 @@ IN: compiler.cfg.branch-splitting
UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
: split-instructions? ( insns -- ? )
[ [ irrelevant? not ] count 5 <= ]
[ last ##fixnum-overflow? not ]
bi and ;
: split-instructions? ( insns -- ? ) [ irrelevant? not ] count 5 <= ;
: split-branch? ( bb -- ? )
{

74
basis/compiler/cfg/builder/blocks/blocks.factor Normal file
View File

@ -0,0 +1,74 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays fry kernel make math namespaces sequences
compiler.cfg compiler.cfg.instructions compiler.cfg.stacks
compiler.cfg.stacks.local ;
IN: compiler.cfg.builder.blocks
: set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi
begin-local-analysis ;
: initial-basic-block ( -- )
<basic-block> set-basic-block ;
: end-basic-block ( -- )
basic-block get [ end-local-analysis ] when
building off
basic-block off ;
: (begin-basic-block) ( -- )
<basic-block>
basic-block get [ dupd successors>> push ] when*
set-basic-block ;
: begin-basic-block ( -- )
basic-block get [ end-local-analysis ] when
(begin-basic-block) ;
: emit-trivial-block ( quot -- )
##branch begin-basic-block
call
##branch begin-basic-block ; inline
: call-height ( #call -- n )
[ out-d>> length ] [ in-d>> length ] bi - ;
: emit-primitive ( node -- )
[
[ word>> ##call ]
[ call-height adjust-d ] bi
] emit-trivial-block ;
: begin-branch ( -- ) clone-current-height (begin-basic-block) ;
: end-branch ( -- pair/f )
! pair is { final-bb final-height }
basic-block get dup [
##branch
end-local-analysis
current-height get clone 2array
] when ;
: with-branch ( quot -- pair/f )
[ begin-branch call end-branch ] with-scope ; inline
: set-successors ( branches -- )
! Set the successor of each branch's final basic block to the
! current block.
basic-block get dup [
'[ [ [ _ ] dip first successors>> push ] when* ] each
] [ 2drop ] if ;
: merge-heights ( branches -- )
! If all elements are f, that means every branch ended with a backward
! jump so the height is irrelevant since this block is unreachable.
[ ] find nip [ second current-height set ] [ end-basic-block ] if* ;
: emit-conditional ( branches -- )
! branchies is a sequence of pairs as above
end-basic-block
[ merge-heights begin-basic-block ]
[ set-successors ]
bi ;

16
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -2,12 +2,21 @@ IN: compiler.cfg.builder.tests
USING: tools.test kernel sequences words sequences.private fry
prettyprint alien alien.accessors math.private compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
compiler.cfg.predecessors compiler.cfg.checker arrays locals
byte-arrays kernel.private math slots.private ;
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
arrays locals byte-arrays kernel.private math slots.private ;
! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- )
'[ _ test-cfg [ compute-predecessors check-cfg ] each ] [ ] swap unit-test ;
'[ _ test-cfg [ optimize-cfg check-cfg ] each ] [ ] swap unit-test ;
: blahblah ( nodes -- ? )
{ fixnum } declare [
dup 3 bitand 1 = [ drop t ] [
dup 3 bitand 2 = [
blahblah
] [ drop f ] if
] if
] any? ; inline recursive
{
[ ]
@ -52,6 +61,7 @@ byte-arrays kernel.private math slots.private ;
[ "int" { "int" } "cdecl" [ ] alien-callback ]
[ swap - + * ]
[ swap slot ]
[ blahblah ]
} [
unit-test-cfg
] each

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

@ -10,30 +10,39 @@ compiler.tree.combinators
compiler.tree.propagation.info
compiler.cfg
compiler.cfg.hats
compiler.cfg.stacks
compiler.cfg.utilities
compiler.cfg.registers
compiler.cfg.intrinsics
compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.cfg.instructions
compiler.cfg.predecessors
compiler.cfg.builder.blocks
compiler.cfg.stacks
compiler.alien ;
IN: compiler.cfg.builder
! Convert tree SSA IR to CFG SSA IR.
! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is
! constructed later by calling compiler.cfg.ssa:construct-ssa.
SYMBOL: procedures
SYMBOL: loops
: begin-procedure ( word label -- )
end-basic-block
begin-basic-block
: begin-cfg ( word label -- cfg )
initial-basic-block
H{ } clone loops set
[ basic-block get ] 2dip
<cfg> procedures get push ;
[ basic-block get ] 2dip <cfg> dup cfg set ;
: begin-procedure ( word label -- )
begin-cfg procedures get push ;
: with-cfg-builder ( nodes word label quot -- )
'[ begin-procedure @ ] with-scope ; inline
'[
begin-stack-analysis
begin-procedure
@
end-stack-analysis
] with-scope ; inline
GENERIC: emit-node ( node -- )
@ -61,17 +70,12 @@ GENERIC: emit-node ( node -- )
: emit-loop-call ( basic-block -- )
##branch
basic-block get successors>> push
basic-block off ;
: emit-trivial-block ( quot -- )
basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless
call
##branch begin-basic-block ; inline
end-basic-block ;
: emit-call ( word height -- )
over loops get key?
[ drop loops get at emit-loop-call ]
[ [ ##call ] emit-trivial-block ]
[ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ]
if ;
! #recursive
@ -86,7 +90,6 @@ GENERIC: emit-node ( node -- )
basic-block get swap loops get set-at ;
: emit-loop ( node -- )
##loop-entry
##branch
begin-basic-block
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
@ -101,9 +104,6 @@ M: #recursive emit-node
: emit-if ( node -- )
children>> [ emit-branch ] map emit-conditional ;
: ##branch-t ( vreg -- )
\ f tag-number cc/= ##compare-imm-branch ;
: trivial-branch? ( nodes -- value ? )
dup length 1 = [
first dup #push? [ literal>> t ] [ drop f f ] if
@ -127,15 +127,23 @@ M: #recursive emit-node
: emit-trivial-not-if ( -- )
ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
: emit-actual-if ( #if -- )
! Inputs to the final instruction need to be copied because of
! loc>vreg sync
ds-pop ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
M: #if emit-node
{
{ [ dup trivial-if? ] [ drop emit-trivial-if ] }
{ [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
[ ds-pop ##branch-t emit-if ]
[ emit-actual-if ]
} cond ;
! #dispatch
M: #dispatch emit-node
! Inputs to the final instruction need to be copied because of
! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
! though.
ds-pop ^^offset>slot i ##dispatch emit-if ;
! #call
@ -161,15 +169,16 @@ M: #shuffle emit-node
[ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
! #return
M: #return emit-node
drop ##branch begin-basic-block ##epilogue ##return ;
: emit-return ( -- )
##branch begin-basic-block ##epilogue ##return ;
M: #return emit-node drop emit-return ;
M: #return-recursive emit-node
label>> id>> loops get key?
[ ##epilogue ##return ] unless ;
label>> id>> loops get key? [ emit-return ] unless ;
! #terminate
M: #terminate emit-node drop ##no-tco basic-block off ;
M: #terminate emit-node drop ##no-tco end-basic-block ;
! FFI
: return-size ( ctype -- n )
@ -186,9 +195,13 @@ M: #terminate emit-node drop ##no-tco basic-block off ;
[ return>> return-size >>return ]
[ alien-parameters parameter-sizes drop >>params ] bi ;
: alien-node-height ( params -- )
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
: emit-alien-node ( node quot -- )
[
[ params>> dup <alien-stack-frame> ] dip call
[ params>> dup dup <alien-stack-frame> ] dip call
alien-node-height
] emit-trivial-block ; inline
M: #alien-invoke emit-node

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

@ -1,16 +1,18 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators.short-circuit accessors math sequences sets
assocs compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use
compiler.cfg.linearization compiler.cfg.liveness
compiler.cfg.utilities ;
USING: kernel compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities
compiler.cfg.mr combinators.short-circuit accessors math
sequences sets assocs ;
IN: compiler.cfg.checker
ERROR: bad-kill-block bb ;
: check-kill-block ( bb -- )
dup instructions>> first2
swap ##epilogue? [ [ ##return? ] [ ##callback-return? ] bi or ] [ ##branch? ] if
swap ##epilogue? [
{ [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1||
] [ ##branch? ] if
[ drop ] [ bad-kill-block ] if ;
ERROR: last-insn-not-a-jump bb ;
@ -27,14 +29,6 @@ ERROR: last-insn-not-a-jump bb ;
[ ##no-tco? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
ERROR: bad-loop-entry bb ;
: check-loop-entry ( bb -- )
dup instructions>> dup length 2 >= [
2 head* [ ##loop-entry? ] any?
[ bad-loop-entry ] [ drop ] if
] [ 2drop ] if ;
ERROR: bad-kill-insn bb ;
: check-kill-instructions ( bb -- )
@ -42,10 +36,9 @@ ERROR: bad-kill-insn bb ;
[ bad-kill-insn ] [ drop ] if ;
: check-normal-block ( bb -- )
[ check-loop-entry ]
[ check-last-instruction ]
[ check-kill-instructions ]
tri ;
bi ;
ERROR: bad-successors ;
@ -70,8 +63,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 ;
[ build-mr check-mr ]
bi ;

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

@ -1,8 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs accessors ;
USING: kernel namespaces assocs accessors sequences
compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.instructions ;
IN: compiler.cfg.copy-prop
! The first three definitions are also used in compiler.cfg.alias-analysis.
SYMBOL: copies
: resolve ( vreg -- vreg )
@ -10,3 +12,25 @@ SYMBOL: copies
: record-copy ( insn -- )
[ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
: collect-copies ( cfg -- )
H{ } clone copies set
[
instructions>>
[ dup ##copy? [ record-copy ] [ drop ] if ] each
] each-basic-block ;
: rename-copies ( cfg -- )
copies get dup assoc-empty? [ 2drop ] [
renamings set
[
instructions>>
[ dup ##copy? [ drop f ] [ rename-insn-uses t ] if ] filter-here
] each-basic-block
] if ;
: copy-propagation ( cfg -- cfg' )
[ collect-copies ]
[ rename-copies ]
[ ]
tri ;

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 ;

621
basis/compiler/cfg/dcn/dcn-tests.factor
View File

@ -1,621 +0,0 @@
IN: compiler.cfg.dcn.tests
USING: tools.test kernel accessors namespaces assocs math
cpu.architecture vectors sequences classes
compiler.cfg
compiler.cfg.utilities
compiler.cfg.debugger
compiler.cfg.registers
compiler.cfg.predecessors
compiler.cfg.instructions
compiler.cfg.checker
compiler.cfg.dcn
compiler.cfg.dcn.height
compiler.cfg.dcn.local
compiler.cfg.dcn.local.private
compiler.cfg.dcn.global
compiler.cfg.dcn.global.private
compiler.cfg.dcn.rewrite ;
: test-local-dcn ( insns -- insns' )
<basic-block> swap >>instructions
[ local-analysis ] keep
instructions>> ;
: inserting-peeks' ( from to -- assoc )
[ inserting-peeks ] keep untranslate-locs keys ;
: inserting-replaces' ( from to -- assoc )
[ inserting-replaces ] keep untranslate-locs remove-dead-stores keys ;
[
V{
T{ ##copy f V int-regs 1 V int-regs 0 }
T{ ##copy f V int-regs 3 V int-regs 2 }
T{ ##copy f V int-regs 5 V int-regs 4 }
T{ ##inc-d f -1 }
T{ ##branch }
}
] [
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f V int-regs 1 D 0 }
T{ ##inc-d f -1 }
T{ ##peek f V int-regs 2 D 0 }
T{ ##peek f V int-regs 3 D 0 }
T{ ##replace f V int-regs 2 D 0 }
T{ ##replace f V int-regs 4 D 1 }
T{ ##peek f V int-regs 5 D 1 }
T{ ##replace f V int-regs 5 D 1 }
T{ ##replace f V int-regs 6 D -1 }
T{ ##branch }
} test-local-dcn
] unit-test
[
H{
{ V int-regs 1 V int-regs 0 }
{ V int-regs 3 V int-regs 2 }
{ V int-regs 5 V int-regs 4 }
}
] [
copies get
] unit-test
[
H{
{ D 0 V int-regs 0 }
{ D 1 V int-regs 2 }
}
] [ reads-locations get ] unit-test
[
H{
{ D 0 V int-regs 6 }
{ D 2 V int-regs 4 }
}
] [ writes-locations get ] unit-test
: test-global-dcn ( -- )
cfg new 0 get >>entry
compute-predecessors
deconcatenatize
check-cfg ;
V{ T{ ##epilogue } T{ ##return } } 0 test-bb
[ ] [ test-global-dcn ] unit-test
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##inc-d f 1 }
T{ ##peek f V int-regs 0 D 1 }
T{ ##load-immediate f V int-regs 1 100 }
T{ ##replace f V int-regs 1 D 2 }
T{ ##branch }
} 1 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 2 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 1vector >>successors drop
[ t ] [ 0 get kill-block? ] unit-test
[ t ] [ 2 get kill-block? ] unit-test
[ ] [ test-global-dcn ] unit-test
[ t ] [ D 0 1 get peek-in key? ] unit-test
[ f ] [ D 0 0 get peek-in key? ] unit-test
[ t ] [ D 0 1 get avail-out key? ] unit-test
[ f ] [ D 0 0 get avail-out key? ] unit-test
[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
[ { D 2 } ] [ 1 get 2 get inserting-replaces' ] unit-test
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##peek f V int-regs 0 D 1 }
T{ ##branch }
} 1 test-bb
V{
T{ ##inc-d f -1 }
T{ ##peek f V int-regs 0 D 0 }
T{ ##branch }
} 2 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 3 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 1vector >>successors drop
2 get 3 get 1vector >>successors drop
[ ] [ test-global-dcn ] unit-test
[ t ] [ D 1 2 get peek-in key? ] unit-test
[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test
[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##branch }
} 1 test-bb
V{
T{ ##inc-d f 1 }
T{ ##peek f V int-regs 0 D 1 }
T{ ##branch }
} 2 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 3 test-bb
V{
T{ ##peek f V int-regs 1 D 0 }
T{ ##peek f V int-regs 2 D 1 }
T{ ##inc-d f 1 }
T{ ##replace f V int-regs 2 D 1 }
T{ ##branch }
} 4 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 5 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 4 get V{ } 2sequence >>successors drop
2 get 3 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
[ ] [ test-global-dcn ] unit-test
[ f ] [ D 0 1 get avail-out key? ] unit-test
[ f ] [ D 1 1 get avail-out key? ] unit-test
[ t ] [ D 0 4 get peek-in key? ] unit-test
[ t ] [ D 1 4 get peek-in key? ] unit-test
[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test
[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test
[ { D 1 } ] [ 1 get 4 get inserting-peeks' ] unit-test
[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test
[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test
[ { D 1 } ] [ 4 get 5 get inserting-replaces' ] unit-test
[ t ] [ D 0 1 get peek-out key? ] unit-test
[ f ] [ D 1 1 get peek-out key? ] unit-test
[ t ] [ D 1 4 get peek-in key? ] unit-test
[ f ] [ D 1 4 get avail-in key? ] unit-test
[ t ] [ D 1 4 get avail-out key? ] unit-test
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##branch }
} 1 test-bb
V{
T{ ##peek f V int-regs 1 D 1 }
T{ ##inc-d f -1 }
T{ ##branch }
} 2 test-bb
V{
T{ ##load-immediate f V int-regs 2 100 }
T{ ##replace f V int-regs 2 D 1 }
T{ ##inc-d f -1 }
T{ ##peek f V int-regs 4 D 1 }
T{ ##branch }
} 3 test-bb
V{
T{ ##load-immediate f V int-regs 3 100 }
T{ ##replace f V int-regs 3 D 0 }
T{ ##branch }
} 4 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 5 test-bb
0 get 1 get 1vector >>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 5 get 1vector >>successors drop
[ ] [ test-global-dcn ] unit-test
[ t ] [ D 1 4 get avail-in key? ] unit-test
[ f ] [ D 2 4 get avail-in key? ] unit-test
[ t ] [ D 1 2 get peek-in key? ] unit-test
[ f ] [ D 1 3 get peek-in key? ] unit-test
[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
[ { D 1 } ] [ 1 get 2 get inserting-peeks' ] unit-test
[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
[ { D 2 } ] [ 1 get 3 get inserting-peeks' ] unit-test
[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test
[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test
[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test
[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test
[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##peek f V int-regs 0 D 1 }
T{ ##branch }
} 1 test-bb
V{
T{ ##inc-d f -1 }
T{ ##branch }
} 2 test-bb
V{
T{ ##call f drop -1 }
T{ ##branch }
} 3 test-bb
V{
T{ ##peek f V int-regs 1 D 0 }
T{ ##branch }
} 4 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 5 test-bb
[ t ] [ 0 get kill-block? ] unit-test
[ t ] [ 3 get kill-block? ] unit-test
0 get 1 get 1vector >>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 5 get 1vector >>successors drop
[ ] [ test-global-dcn ] unit-test
[ t ] [ D 1 2 get avail-out key? ] unit-test
[ f ] [ D 1 3 get peek-out key? ] unit-test
[ f ] [ D 1 3 get avail-out key? ] unit-test
[ f ] [ D 1 4 get avail-in key? ] unit-test
[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test
[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test
[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test
[ { D 0 } ] [ 3 get 4 get inserting-peeks' ] unit-test
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##branch }
} 1 test-bb
V{ T{ ##epilogue } T{ ##return } } 2 test-bb
V{ T{ ##branch } } 3 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 3 get V{ } 2sequence >>successors drop
3 get 1 get 1vector >>successors drop
[ ] [ test-global-dcn ] unit-test
[ t ] [ D 0 1 get avail-out key? ] unit-test
[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test
[ { } ] [ 3 get 1 get inserting-peeks' ] unit-test
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##branch }
} 1 test-bb
V{
T{ ##call f drop }
T{ ##branch }
} 2 test-bb
V{
T{ ##branch }
} 3 test-bb
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##branch }
} 4 test-bb
V{
T{ ##peek f V int-regs 1 D 0 }
T{ ##branch }
} 5 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 6 test-bb
0 get 1 get 1vector >>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 5 get 1vector >>successors drop
5 get 6 get 1vector >>successors drop
[ ] [ test-global-dcn ] unit-test
[ { } ] [ 0 get 1 get inserting-peeks' ] unit-test
[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test
[ { D 0 } ] [ 2 get 4 get inserting-peeks' ] unit-test
[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test
[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test
[ { } ] [ 5 get 6 get inserting-peeks' ] unit-test
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##branch }
} 1 test-bb
V{
T{ ##load-immediate f V int-regs 1 100 }
T{ ##replace f V int-regs 1 D 0 }
T{ ##branch }
} 2 test-bb
V{
T{ ##peek f V int-regs 2 D 0 }
T{ ##branch }
} 3 test-bb
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##branch }
} 4 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 5 test-bb
0 get 1 get 1vector >>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 5 get 1vector >>successors drop
[ ] [ test-global-dcn ] unit-test
[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test
[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test
[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test
[ { D 0 } ] [ 2 get 4 get inserting-replaces' ] unit-test
[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test
[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test
[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test
[ { } ] [ 4 get 5 get inserting-replaces' ] unit-test
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##branch }
} 1 test-bb
V{
T{ ##load-immediate f V int-regs 1 100 }
T{ ##replace f V int-regs 1 D 0 }
T{ ##branch }
} 2 test-bb
V{
T{ ##load-immediate f V int-regs 2 100 }
T{ ##replace f V int-regs 2 D 0 }
T{ ##branch }
} 3 test-bb
V{
T{ ##branch }
} 4 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 5 test-bb
0 get 1 get 1vector >>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 5 get 1vector >>successors drop
[ ] [ test-global-dcn ] unit-test
[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test
[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test
[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test
! Dead replace elimination
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f V int-regs 1 D 1 }
T{ ##replace f V int-regs 1 D 0 }
T{ ##replace f V int-regs 0 D 1 }
T{ ##branch }
} 1 test-bb
V{
T{ ##inc-d f -2 }
T{ ##branch }
} 2 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 3 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 1vector >>successors drop
2 get 3 get 1vector >>successors drop
[ ] [ test-global-dcn ] unit-test
[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
[ { } ] [ 2 get 3 get inserting-replaces' ] unit-test
! More dead replace elimination tests
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##peek { dst V int-regs 10 } { loc D 0 } }
T{ ##inc-d { n -1 } }
T{ ##inc-r { n 1 } }
T{ ##replace { src V int-regs 10 } { loc R 0 } }
T{ ##peek { dst V int-regs 12 } { loc R 0 } }
T{ ##inc-r { n -1 } }
T{ ##inc-d { n 1 } }
T{ ##replace { src V int-regs 12 } { loc D 0 } }
T{ ##branch }
} 1 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 2 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 1vector >>successors drop
[ ] [ test-global-dcn ] unit-test
[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
! Check that retain stack usage works
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##inc-d f -1 }
T{ ##inc-r f 1 }
T{ ##replace f V int-regs 0 R 0 }
T{ ##branch }
} 1 test-bb
V{
T{ ##call f + -1 }
T{ ##branch }
} 2 test-bb
V{
T{ ##peek f V int-regs 0 R 0 }
T{ ##inc-r f -1 }
T{ ##inc-d f 1 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##branch }
} 3 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 4 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 1vector >>successors drop
2 get 3 get 1vector >>successors drop
3 get 4 get 1vector >>successors drop
[ ] [ test-global-dcn ] unit-test
[ ##replace D 0 ] [
3 get successors>> first instructions>> first
[ class ] [ loc>> ] bi
] unit-test
[ ##replace R 0 ] [
1 get successors>> first instructions>> first
[ class ] [ loc>> ] bi
] unit-test
[ ##peek R 0 ] [
2 get successors>> first instructions>> first
[ class ] [ loc>> ] bi
] unit-test

44
basis/compiler/cfg/dcn/dcn.factor
View File

@ -1,44 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators
compiler.cfg
compiler.cfg.dcn.height
compiler.cfg.dcn.local
compiler.cfg.dcn.global
compiler.cfg.dcn.rewrite ;
IN: compiler.cfg.dcn
! "DeConcatenatizatioN" -- dataflow analysis to recover registers
! from stack locations.
! Local sets:
! - P(b): locations that block b peeks before replacing
! - R(b): locations that block b replaces
! - A(b): P(b) \/ R(b) -- locations that are available in registers at the end of b
! Global sets:
! - P_out(b) = /\ P_in(sux) for sux in successors(b)
! - P_in(b) = (P_out(b) - R(b)) \/ P(b)
!
! - R_in(b) = R_out(b) \/ R(b)
! - R_out(b) = \/ R_in(sux) for sux in successors(b)
!
! - A_in(b) = /\ A_out(pred) for pred in predecessors(b)
! - A_out(b) = A_in(b) \/ P(b) \/ R(b)
! On every edge [b --> sux], insert a replace for each location in
! R_out(b) - R_in(sux)
! On every edge [pred --> b], insert a peek for each location in
! P_in(b) - (P_out(pred) \/ A_out(pred))
! Locations are height-normalized.
: deconcatenatize ( cfg -- cfg' )
{
[ compute-heights ]
[ compute-local-sets ]
[ compute-global-sets ]
[ rewrite ]
[ cfg-changed ]
} cleave ;

197
basis/compiler/cfg/dcn/global/global.factor
View File

@ -1,197 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs deques dlists fry kernel namespaces sequences
combinators combinators.short-circuit compiler.cfg.instructions
compiler.cfg.dcn.local compiler.cfg.rpo compiler.cfg.utilities
compiler.cfg ;
IN: compiler.cfg.dcn.global
<PRIVATE
: assoc-refine ( seq -- assoc )
[ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
SYMBOL: work-list
: add-to-work-list ( basic-blocks -- )
work-list get '[ _ push-front ] each ;
! Peek analysis. Peek-in is the set of all locations anticipated at
! the start of a basic block.
SYMBOLS: peek-ins peek-outs ;
PRIVATE>
: peek-in ( bb -- assoc ) peek-ins get at ;
: peek-out ( bb -- assoc ) peek-outs get at ;
<PRIVATE
GENERIC: compute-peek-in ( bb -- assoc )
M: basic-block compute-peek-in
[ [ peek-out ] [ replace ] bi assoc-diff ] [ peek ] bi assoc-union ;
M: kill-block compute-peek-in drop f ;
: update-peek-in ( bb -- ? )
[ compute-peek-in ] keep peek-ins get maybe-set-at ;
GENERIC: compute-peek-out ( bb -- assoc )
M: basic-block compute-peek-out
successors>> peek-ins get '[ _ at ] map assoc-refine ;
M: kill-block compute-peek-out drop f ;
: update-peek-out ( bb -- ? )
[ compute-peek-out ] keep peek-outs get maybe-set-at ;
: peek-step ( bb -- )
dup update-peek-out [
dup update-peek-in
[ predecessors>> add-to-work-list ] [ drop ] if
] [ drop ] if ;
: compute-peek-sets ( cfg -- )
H{ } clone peek-ins set
H{ } clone peek-outs set
post-order add-to-work-list work-list get [ peek-step ] slurp-deque ;
! Replace analysis. Replace-in is the set of all locations which
! will be overwritten at some point after the start of a basic block.
SYMBOLS: replace-ins replace-outs ;
PRIVATE>
: replace-in ( bb -- assoc ) replace-ins get at ;
: replace-out ( bb -- assoc ) replace-outs get at ;
<PRIVATE
GENERIC: compute-replace-in ( bb -- assoc )
M: basic-block compute-replace-in
predecessors>> replace-outs get '[ _ at ] map assoc-refine ;
M: kill-block compute-replace-in drop f ;
: update-replace-in ( bb -- ? )
[ compute-replace-in ] keep replace-ins get maybe-set-at ;
GENERIC: compute-replace-out ( bb -- assoc )
M: basic-block compute-replace-out
[ replace-in ] [ replace ] bi assoc-union ;
M: kill-block compute-replace-out drop f ;
: update-replace-out ( bb -- ? )
[ compute-replace-out ] keep replace-outs get maybe-set-at ;
: replace-step ( bb -- )
dup update-replace-in [
dup update-replace-out
[ successors>> add-to-work-list ] [ drop ] if
] [ drop ] if ;
: compute-replace-sets ( cfg -- )
H{ } clone replace-ins set
H{ } clone replace-outs set
reverse-post-order add-to-work-list work-list get [ replace-step ] slurp-deque ;
! Availability analysis. Avail-out is the set of all locations
! in registers at the end of a basic block.
SYMBOLS: avail-ins avail-outs ;
PRIVATE>
: avail-in ( bb -- assoc ) avail-ins get at ;
: avail-out ( bb -- assoc ) avail-outs get at ;
<PRIVATE
GENERIC: compute-avail-in ( bb -- assoc )
M: basic-block compute-avail-in
predecessors>> avail-outs get '[ _ at ] map assoc-refine ;
M: kill-block compute-avail-in drop f ;
: update-avail-in ( bb -- ? )
[ compute-avail-in ] keep avail-ins get maybe-set-at ;
GENERIC: compute-avail-out ( bb -- assoc )
M: basic-block compute-avail-out
[ avail-in ] [ peek ] [ replace ] tri assoc-union assoc-union ;
M: kill-block compute-avail-out drop f ;
: update-avail-out ( bb -- ? )
[ compute-avail-out ] keep avail-outs get maybe-set-at ;
: avail-step ( bb -- )
dup update-avail-in [
dup update-avail-out
[ successors>> add-to-work-list ] [ drop ] if
] [ drop ] if ;
: compute-avail-sets ( cfg -- )
H{ } clone avail-ins set
H{ } clone avail-outs set
reverse-post-order add-to-work-list work-list get [ avail-step ] slurp-deque ;
! Kill analysis. Kill-in is the set of all locations
! which are going to be overwritten.
SYMBOLS: kill-ins kill-outs ;
PRIVATE>
: kill-in ( bb -- assoc ) kill-ins get at ;
: kill-out ( bb -- assoc ) kill-outs get at ;
<PRIVATE
GENERIC: compute-kill-in ( bb -- assoc )
M: basic-block compute-kill-in
[ kill-out ] [ replace ] bi assoc-union ;
M: kill-block compute-kill-in drop f ;
: update-kill-in ( bb -- ? )
[ compute-kill-in ] keep kill-ins get maybe-set-at ;
GENERIC: compute-kill-out ( bb -- assoc )
M: basic-block compute-kill-out
successors>> kill-ins get '[ _ at ] map assoc-refine ;
M: kill-block compute-kill-out drop f ;
: update-kill-out ( bb -- ? )
[ compute-kill-out ] keep kill-outs get maybe-set-at ;
: kill-step ( bb -- )
dup update-kill-out [
dup update-kill-in
[ predecessors>> add-to-work-list ] [ drop ] if
] [ drop ] if ;
: compute-kill-sets ( cfg -- )
H{ } clone kill-ins set
H{ } clone kill-outs set
post-order add-to-work-list work-list get [ kill-step ] slurp-deque ;
PRIVATE>
! Main word
: compute-global-sets ( cfg -- )
<hashed-dlist> work-list set
{
[ compute-peek-sets ]
[ compute-replace-sets ]
[ compute-avail-sets ]
[ compute-kill-sets ]
} cleave ;

82
basis/compiler/cfg/dcn/height/height.factor
View File

@ -1,82 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs accessors sequences kernel math locals fry
compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.registers ;
IN: compiler.cfg.dcn.height
! Compute block in-height and out-height sets. These are relative to the
! stack height from the start of the procedure.
<PRIVATE
SYMBOLS: in-ds-heights out-ds-heights in-rs-heights out-rs-heights ;
GENERIC: ds-height-change ( insn -- n )
M: insn ds-height-change drop 0 ;
M: ##inc-d ds-height-change n>> ;
M: ##call ds-height-change height>> ;
: alien-node-height ( node -- n )
params>> [ out-d>> length ] [ in-d>> length ] bi - ;
M: ##alien-invoke ds-height-change alien-node-height ;
M: ##alien-indirect ds-height-change alien-node-height ;
GENERIC: rs-height-change ( insn -- n )
M: insn rs-height-change drop 0 ;
M: ##inc-r rs-height-change n>> ;
:: compute-in-height ( bb in out -- )
bb predecessors>> [ out at ] map-find drop 0 or
bb in set-at ;
:: compute-out-height ( bb in out quot -- )
bb instructions>>
bb in at
[ quot call + ] reduce
bb out set-at ; inline
:: compute-height ( bb in out quot -- )
bb in get out get
[ compute-in-height ]
[ quot compute-out-height ] 3bi ; inline
: compute-ds-height ( bb -- )
in-ds-heights out-ds-heights [ ds-height-change ] compute-height ;
: compute-rs-height ( bb -- )
in-rs-heights out-rs-heights [ rs-height-change ] compute-height ;
PRIVATE>
: compute-heights ( cfg -- )
H{ } clone in-ds-heights set
H{ } clone out-ds-heights set
H{ } clone in-rs-heights set
H{ } clone out-rs-heights set
[
[ compute-rs-height ]
[ compute-ds-height ] bi
] each-basic-block ;
GENERIC# translate-loc 1 ( loc bb -- loc' )
M: ds-loc translate-loc [ n>> ] [ in-ds-heights get at ] bi* - <ds-loc> ;
M: rs-loc translate-loc [ n>> ] [ in-rs-heights get at ] bi* - <rs-loc> ;
: translate-locs ( assoc bb -- assoc' )
'[ [ _ translate-loc ] dip ] assoc-map ;
GENERIC# untranslate-loc 1 ( loc bb -- loc' )
M: ds-loc untranslate-loc [ n>> ] [ in-ds-heights get at ] bi* + <ds-loc> ;
M: rs-loc untranslate-loc [ n>> ] [ in-rs-heights get at ] bi* + <rs-loc> ;
: untranslate-locs ( assoc bb -- assoc' )
'[ [ _ untranslate-loc ] dip ] assoc-map ;

101
basis/compiler/cfg/dcn/local/local.factor
View File

@ -1,101 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel make namespaces sequences math
compiler.cfg.rpo compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.dcn.height ;
IN: compiler.cfg.dcn.local
<PRIVATE
SYMBOL: copies
: record-copy ( dst src -- ) swap copies get set-at ;
: resolve-copy ( vreg -- vreg' ) copies get ?at drop ;
SYMBOLS: reads-locations writes-locations ;
: loc>vreg ( loc -- vreg )
dup writes-locations get at
[ ] [ reads-locations get at ] ?if ;
SYMBOL: ds-height
SYMBOL: rs-height
GENERIC: translate-loc ( loc -- loc' )
M: ds-loc translate-loc n>> ds-height get - <ds-loc> ;
M: rs-loc translate-loc n>> rs-height get - <rs-loc> ;
GENERIC: visit ( insn -- )
M: insn visit , ;
M: ##inc-d visit n>> ds-height [ + ] change ;
M: ##inc-r visit n>> rs-height [ + ] change ;
M: ##peek visit
! If location is in a register already, copy existing
! register to destination. Otherwise, associate the
! location with the register.
[ dst>> ] [ loc>> translate-loc ] bi dup loc>vreg
[ [ record-copy ] [ ##copy ] 2bi ]
[ reads-locations get set-at ]
?if ;
M: ##replace visit
! If location already contains the same value, do nothing.
! Otherwise, associate the location with the register.
[ src>> resolve-copy ] [ loc>> translate-loc ] bi 2dup loc>vreg =
[ 2drop ] [ writes-locations get set-at ] if ;
M: ##copy visit
! Not needed at this point because IR doesn't have ##copy
! on input to dcn pass, but in the future it might.
[ dst>> ] [ src>> resolve-copy ] bi record-copy ;
: insert-height-changes ( -- )
ds-height get dup 0 = [ drop ] [ ##inc-d ] if
rs-height get dup 0 = [ drop ] [ ##inc-r ] if ;
: init-local-analysis ( -- )
0 ds-height set
0 rs-height set
H{ } clone copies set
H{ } clone reads-locations set
H{ } clone writes-locations set ;
: local-analysis ( bb -- )
! Removes all ##peek and ##replace from the basic block.
! Conceptually, moves all ##peeks to the start
! (reads-locations assoc) and all ##replaces to the end
! (writes-locations assoc).
init-local-analysis
[
[
unclip-last-slice [ [ visit ] each ] dip
insert-height-changes
,
] V{ } make
] change-instructions drop ;
SYMBOLS: peeks replaces ;
: visit-block ( bb -- )
[ local-analysis ]
[ [ reads-locations get ] dip [ translate-locs ] keep peeks get set-at ]
[ [ writes-locations get ] dip [ translate-locs ] keep replaces get set-at ]
tri ;
PRIVATE>
: peek ( bb -- assoc ) peeks get at ;
: replace ( bb -- assoc ) replaces get at ;
: compute-local-sets ( cfg -- )
H{ } clone peeks set
H{ } clone replaces set
[ visit-block ] each-basic-block ;

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

3
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 )

25
basis/compiler/cfg/dominance/dominance-tests.factor
View File

@ -6,8 +6,7 @@ compiler.cfg.predecessors ;
: test-dominance ( -- )
cfg new 0 get >>entry
compute-predecessors
compute-dominance
drop ;
compute-dominance ;
! Example with no back edges
V{ } 0 test-bb
@ -74,3 +73,25 @@ V{ } 5 test-bb
[ ] [ 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

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

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators sets math fry kernel math.order
namespaces sequences sorting compiler.cfg.rpo ;
dlists deques namespaces sequences sorting compiler.cfg.rpo ;
IN: compiler.cfg.dominance
! Reference:
@ -85,8 +85,31 @@ PRIVATE>
PRIVATE>
: compute-dominance ( cfg -- cfg' )
: compute-dominance ( cfg -- )
[ compute-dom-parents compute-dom-children ]
[ compute-dom-frontiers ]
[ ]
tri ;
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 ;

38
basis/compiler/cfg/empty-blocks/empty-blocks.factor Normal file
View File

@ -0,0 +1,38 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences combinators combinators.short-circuit
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.empty-blocks
: update-predecessor ( bb -- )
! We have to replace occurrences of bb with bb's successor
! in bb's predecessor's list of successors.
dup predecessors>> first [
[
2dup eq? [ drop successors>> first ] [ nip ] if
] with map
] change-successors drop ;
: update-successor ( bb -- )
! We have to replace occurrences of bb with bb's predecessor
! in bb's sucessor's list of predecessors.
dup successors>> first [
[
2dup eq? [ drop predecessors>> first ] [ nip ] if
] with map
] change-predecessors drop ;
: delete-basic-block ( bb -- )
[ update-predecessor ] [ update-successor ] bi ;
: delete-basic-block? ( bb -- ? )
{
[ instructions>> length 1 = ]
[ predecessors>> length 1 = ]
[ successors>> length 1 = ]
[ instructions>> first ##branch? ]
} 1&& ;
: delete-empty-blocks ( cfg -- cfg' )
dup [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if ] each-basic-block
cfg-changed ;

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

@ -18,7 +18,7 @@ IN: compiler.cfg.hats
: ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline
: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline
: ^^copy ( src -- dst ) ^^i1 ##copy ; inline
: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
@ -74,7 +74,7 @@ IN: compiler.cfg.hats
: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
: ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline

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

@ -52,7 +52,7 @@ INSN: ##inc-d { n integer } ;
INSN: ##inc-r { n integer } ;
! Subroutine calls
INSN: ##call word { height integer } ;
INSN: ##call word ;
INSN: ##jump word ;
INSN: ##return ;
@ -170,8 +170,6 @@ INSN: ##epilogue ;
INSN: ##branch ;
INSN: ##loop-entry ;
INSN: ##phi < ##pure inputs ;
! Conditionals
@ -201,6 +199,7 @@ INSN: _epilogue stack-frame ;
INSN: _label id ;
INSN: _branch label ;
INSN: _loop-entry ;
INSN: _dispatch src temp ;
INSN: _dispatch-label label ;

9
basis/compiler/cfg/intrinsics/alien/alien.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences alien math classes.algebra
fry locals combinators cpu.architecture
compiler.tree.propagation.info
USING: accessors kernel sequences alien math classes.algebra fry
locals combinators cpu.architecture compiler.tree.propagation.info
compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
compiler.cfg.utilities ;
compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.alien
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )

4
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order sequences accessors arrays
byte-arrays layouts classes.tuple.private fry locals
compiler.tree.propagation.info compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.stacks
compiler.cfg.utilities ;
compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.allot
: ##set-slots ( regs obj class -- )

11
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -7,6 +7,7 @@ compiler.cfg.hats
compiler.cfg.stacks
compiler.cfg.instructions
compiler.cfg.utilities
compiler.cfg.builder.blocks
compiler.cfg.registers
compiler.cfg.comparisons ;
IN: compiler.cfg.intrinsics.fixnum
@ -31,7 +32,7 @@ IN: compiler.cfg.intrinsics.fixnum
[ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ;
: emit-fixnum-shift-general ( -- )
D 0 ^^peek 0 cc> ##compare-imm-branch
ds-peek 0 cc> ##compare-imm-branch
[ emit-fixnum-left-shift ] with-branch
[ emit-fixnum-right-shift ] with-branch
2array emit-conditional ;
@ -62,13 +63,15 @@ IN: compiler.cfg.intrinsics.fixnum
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
: emit-no-overflow-case ( dst -- final-bb )
[ -2 ##inc-d ds-push ] with-branch ;
[ ds-drop ds-drop ds-push ] with-branch ;
: emit-overflow-case ( word -- final-bb )
[ -1 ##call ] with-branch ;
[ ##call -1 adjust-d ] with-branch ;
: emit-fixnum-overflow-op ( quot word -- )
[ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip
! Inputs to the final instruction need to be copied because
! of loc>vreg sync
[ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip
[ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
emit-conditional ; inline

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

@ -48,11 +48,11 @@ IN: compiler.cfg.intrinsics
slots.private:set-slot
strings.private:string-nth
strings.private:set-string-nth-fast
classes.tuple.private:<tuple-boa>
arrays:<array>
byte-arrays:<byte-array>
byte-arrays:(byte-array)
kernel:<wrapper>
! classes.tuple.private:<tuple-boa>
! arrays:<array>
! byte-arrays:<byte-array>
! byte-arrays:(byte-array)
! kernel:<wrapper>
alien.accessors:alien-unsigned-1
alien.accessors:set-alien-unsigned-1
alien.accessors:alien-signed-1
@ -61,7 +61,7 @@ IN: compiler.cfg.intrinsics
alien.accessors:set-alien-unsigned-2
alien.accessors:alien-signed-2
alien.accessors:set-alien-signed-2
alien.accessors:alien-cell
! alien.accessors:alien-cell
alien.accessors:set-alien-cell
} [ t "intrinsic" set-word-prop ] each
@ -90,7 +90,7 @@ IN: compiler.cfg.intrinsics
alien.accessors:set-alien-float
alien.accessors:alien-double
alien.accessors:set-alien-double
} [ t "intrinsic" set-word-prop ] each ;
} drop f [ t "intrinsic" set-word-prop ] each ;
: enable-fixnum-log2 ( -- )
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;

4
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: layouts namespaces kernel accessors sequences
classes.algebra compiler.tree.propagation.info
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.utilities ;
compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.slots
: value-tag ( info -- n ) class>> class-tag ; inline

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 )

10
basis/compiler/cfg/linear-scan/mapping/mapping.factor
View File

@ -44,17 +44,11 @@ M: register->register >insn
SYMBOL: froms
SYMBOL: tos
SINGLETONS: memory register ;
: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
: from-reg ( operation -- seq )
[ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
[ from>> ] [ reg-class>> ] bi 2array ;
: to-reg ( operation -- seq )
[ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
[ to>> ] [ reg-class>> ] bi 2array ;
: start? ( operations -- pair )
from-reg tos get key? not ;

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 ;

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

@ -4,10 +4,10 @@ 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 ;
compiler.cfg.instructions
compiler.cfg.utilities ;
IN: compiler.cfg.linearization
! Convert CFG IR to machine IR.
@ -25,7 +25,12 @@ M: insn linearize-insn , drop ;
#! don't need to branch.
[ number>> ] bi@ 1 - = ; inline
: emit-branch ( basic-block successor -- )
: emit-loop-entry? ( bb successor -- ? )
[ back-edge? not ]
[ nip dup predecessors>> [ swap back-edge? ] with any? ] 2bi and ;
: emit-branch ( bb successor -- )
2dup emit-loop-entry? [ _loop-entry ] when
2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
M: ##branch linearize-insn
@ -33,11 +38,11 @@ M: ##branch linearize-insn
: successors ( bb -- first second ) successors>> first2 ; inline
: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
[ dup successors ]
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
[ (binary-conditional) ]
[ drop dup successors>> second useless-branch? ] 2bi
[ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
@ -54,7 +59,7 @@ M: ##compare-imm-branch linearize-insn
M: ##compare-float-branch linearize-insn
[ binary-conditional _compare-float-branch ] with-regs emit-branch ;
: overflow-conditional ( basic-block insn -- basic-block successor label2 dst src1 src2 )
: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
[ dup successors number>> ]
[ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline

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

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

@ -1,79 +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 ;
: 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

12
basis/compiler/cfg/optimizer/optimizer-tests.factor
View File

@ -1,8 +1,8 @@
USING: accessors arrays compiler.cfg.checker
compiler.cfg.debugger compiler.cfg.def-use
compiler.cfg.instructions fry kernel kernel.private math
math.partial-dispatch math.private sbufs sequences sequences.private sets
slots.private strings strings.private tools.test vectors layouts ;
USING: accessors arrays compiler.cfg.checker compiler.cfg.debugger
compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.optimizer
fry kernel kernel.private math math.partial-dispatch math.private
sbufs sequences sequences.private sets slots.private strings
strings.private tools.test vectors layouts ;
IN: compiler.cfg.optimizer.tests
! Miscellaneous tests
@ -45,7 +45,7 @@ IN: compiler.cfg.optimizer.tests
set-string-nth-fast
]
} [
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
[ [ ] ] dip '[ _ test-cfg first optimize-cfg check-cfg ] unit-test
] each
cell 8 = [

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

@ -2,21 +2,19 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors combinators namespaces
compiler.cfg.tco
compiler.cfg.predecessors
compiler.cfg.useless-conditionals
compiler.cfg.stack-analysis
compiler.cfg.dcn
compiler.cfg.dominance
compiler.cfg.ssa
compiler.cfg.branch-splitting
compiler.cfg.block-joining
compiler.cfg.ssa
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
compiler.cfg.copy-prop
compiler.cfg.dce
compiler.cfg.write-barrier
compiler.cfg.liveness
compiler.cfg.rpo
compiler.cfg.phi-elimination
compiler.cfg.empty-blocks
compiler.cfg.predecessors
compiler.cfg.rpo
compiler.cfg.checker ;
IN: compiler.cfg.optimizer
@ -27,30 +25,24 @@ SYMBOL: check-optimizer?
dup check-cfg
] when ;
SYMBOL: new-optimizer?
: optimize-cfg ( cfg -- cfg' )
! Note that compute-predecessors has to be called several times.
! The passes that need this document it.
[
optimize-tail-calls
new-optimizer? get [ delete-useless-conditionals ] unless
delete-useless-conditionals
compute-predecessors
new-optimizer? get [ split-branches ] unless
new-optimizer? get [
deconcatenatize
compute-dominance
construct-ssa
] when
split-branches
join-blocks
compute-predecessors
new-optimizer? get [ stack-analysis ] unless
compute-liveness
construct-ssa
alias-analysis
value-numbering
compute-predecessors
copy-propagation
eliminate-dead-code
eliminate-write-barriers
eliminate-phis
delete-empty-blocks
?check
] with-scope ;

14
basis/compiler/cfg/phi-elimination/phi-elimination.factor
View File

@ -6,6 +6,20 @@ compiler.cfg.utilities compiler.cfg.hats make
locals ;
IN: compiler.cfg.phi-elimination
! assoc mapping predecessors to sequences
SYMBOL: added-instructions
: add-instructions ( predecessor quot -- )
[
added-instructions get
[ drop V{ } clone ] cache
building
] dip with-variable ; inline
: insert-basic-blocks ( bb -- )
[ added-instructions get ] dip
'[ [ _ ] dip <simple-block> insert-basic-block ] assoc-each ;
: insert-copy ( predecessor input output -- )
'[ _ _ swap ##copy ] add-instructions ;

6
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 -- )
@ -102,6 +102,10 @@ M: ##fixnum-overflow rename-insn-uses
[ rename-value ] change-src2
drop ;
M: ##phi rename-insn-uses
[ [ rename-value ] assoc-map ] change-inputs
drop ;
M: insn rename-insn-uses drop ;
: fresh-vreg ( vreg -- vreg' )

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

44
basis/compiler/cfg/ssa/ssa-tests.factor
View File

@ -5,9 +5,12 @@ compiler.cfg.registers cpu.architecture kernel namespaces sequences
tools.test vectors ;
IN: compiler.cfg.ssa.tests
! Reset counters so that results are deterministic w.r.t. hash order
0 vreg-counter set-global
0 basic-block set-global
: 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 }
@ -38,7 +41,6 @@ V{
: test-ssa ( -- )
cfg new 0 get >>entry
compute-predecessors
compute-dominance
construct-ssa
drop ;
@ -67,6 +69,9 @@ V{
}
] [ 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 } } }
@ -75,5 +80,34 @@ V{
}
] [
3 get instructions>>
[ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map
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

59
basis/compiler/cfg/ssa/ssa.factor
View File

@ -1,19 +1,21 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel accessors sequences fry dlists
deques assocs sets math combinators sorting
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 and dominance must be computed first.
! SSA construction. Predecessors must be computed first.
! This is the classical algorithm based on dominance frontiers:
! 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:
@ -32,45 +34,22 @@ SYMBOL: inserting-phi-nodes
'[
dup instructions>> [
defs-vregs [
_ push-at
_ conjoin-at
] with each
] with each
] each-basic-block ;
SYMBOLS: has-already ever-on-work-list work-list ;
: init-insert-phi-nodes ( bbs -- )
H{ } clone has-already set
[ unique ever-on-work-list set ]
[ <hashed-dlist> [ push-all-front ] keep work-list set ] bi ;
: add-to-work-list ( bb -- )
dup ever-on-work-list get key? [ drop ] [
[ ever-on-work-list get conjoin ]
[ work-list get push-front ]
bi
] if ;
: insert-phi-node-later ( vreg bb -- )
[ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
inserting-phi-nodes get push-at ;
: compute-phi-node-in ( vreg bb -- )
dup has-already get key? [ 2drop ] [
[ insert-phi-node-later ]
[ has-already get conjoin ]
[ add-to-work-list ]
tri
] if ;
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 -- )
dup length 2 >= [
init-insert-phi-nodes
work-list get [
dom-frontier [
compute-phi-node-in
] with each
] with slurp-deque
keys dup length 2 >= [
iterated-dom-frontier [
insert-phi-node-later
] with each
] [ 2drop ] if ;
: compute-phi-nodes ( -- )
@ -143,4 +122,10 @@ M: ##phi rename-insn
PRIVATE>
: construct-ssa ( cfg -- cfg' )
dup [ compute-defs compute-phi-nodes insert-phi-nodes ] [ rename ] bi ;
{
[ ]
[ compute-live-sets ]
[ compute-dominance ]
[ compute-defs compute-phi-nodes insert-phi-nodes ]
[ rename ]
} cleave ;

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

@ -1 +0,0 @@
Slava Pestov

104
basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
View File

@ -1,104 +0,0 @@
IN: compiler.cfg.stack-analysis.merge.tests
USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
compiler.cfg.instructions compiler.cfg.stack-analysis.state
compiler.cfg.utilities compiler.cfg compiler.cfg.registers
compiler.cfg.debugger cpu.architecture make assocs namespaces
sequences kernel classes ;
[
{ D 0 }
{ V int-regs 0 V int-regs 1 }
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
<state> H{ { D 0 V int-regs 0 } } >>locs>vregs
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
H{ } clone added-instructions set
V{ } clone added-phis set
merge-locs locs>vregs>> keys added-phis get values first
] unit-test
[
{ D 0 }
##peek
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
<state>
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
H{ } clone added-instructions set
V{ } clone added-phis set
[ merge-locs locs>vregs>> keys ] { } make drop
1 get added-instructions get at first class
] unit-test
[
0 ##inc-d
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
H{ } clone added-instructions set
V{ } clone added-phis set
<state> -1 >>ds-height
<state> 2array
[ merge-ds-heights ds-height>> ] { } make drop
1 get added-instructions get at first class
] unit-test
[
0
{ D 0 }
{ 1 1 }
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
H{ } clone added-instructions set
V{ } clone added-phis set
[
<state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
[ merge-locs [ ds-height>> ] [ locs>vregs>> keys ] bi ] { } make drop
] keep
[ instructions>> length ] map
] unit-test
[
-1
{ D -1 }
{ 1 1 }
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
H{ } clone added-instructions set
V{ } clone added-phis set
[
<state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
<state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array
[ [ merge-ds-heights ] [ merge-locs ] 2bi ] { } make drop
[ ds-height>> ] [ locs>vregs>> keys ] bi
] keep
[ instructions>> length ] map
] unit-test

117
basis/compiler/cfg/stack-analysis/merge/merge.factor
View File

@ -1,117 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs sequences accessors fry combinators grouping sets
arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.stack-analysis.state
compiler.cfg.registers compiler.cfg.utilities cpu.architecture ;
IN: compiler.cfg.stack-analysis.merge
: initial-state ( bb states -- state ) 2drop <state> ;
: single-predecessor ( bb states -- state ) nip first clone ;
: save-ds-height ( n -- )
dup 0 = [ drop ] [ ##inc-d ] if ;
: merge-ds-heights ( state predecessors states -- state )
[ ds-height>> ] map dup all-equal?
[ nip first >>ds-height ]
[ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ;
: save-rs-height ( n -- )
dup 0 = [ drop ] [ ##inc-r ] if ;
: merge-rs-heights ( state predecessors states -- state )
[ rs-height>> ] map dup all-equal?
[ nip first >>rs-height ]
[ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
: assoc-map-keys ( assoc quot -- assoc' )
'[ _ dip ] assoc-map ; inline
: translate-locs ( assoc state -- assoc' )
'[ _ translate-loc ] assoc-map-keys ;
: untranslate-locs ( assoc state -- assoc' )
'[ _ untranslate-loc ] assoc-map-keys ;
: collect-locs ( loc-maps states -- assoc )
! assoc maps locs to sequences
[ untranslate-locs ] 2map
[ [ keys ] map concat prune ] keep
'[ dup _ [ at ] with map ] H{ } map>assoc ;
: insert-peek ( predecessor loc state -- vreg )
'[ _ _ translate-loc ^^peek ] add-instructions ;
SYMBOL: added-phis
: add-phi-later ( inputs -- vreg )
[ int-regs next-vreg dup ] dip 2array added-phis get push ;
: merge-loc ( predecessors vregs loc state -- vreg )
! Insert a ##phi in the current block where the input
! is the vreg storing loc from each predecessor block
'[ [ ] [ _ _ insert-peek ] ?if ] 2map
dup all-equal? [ first ] [ add-phi-later ] if ;
:: merge-locs ( state predecessors states -- state )
states [ locs>vregs>> ] map states collect-locs
[| key value |
key
predecessors value key state merge-loc
] assoc-map
state translate-locs
state (>>locs>vregs)
state ;
: merge-actual-loc ( vregs -- vreg/f )
dup all-equal? [ first ] [ drop f ] if ;
:: merge-actual-locs ( state states -- state )
states [ actual-locs>vregs>> ] map states collect-locs
[ merge-actual-loc ] assoc-map [ nip ] assoc-filter
state translate-locs
state (>>actual-locs>vregs)
state ;
: merge-changed-locs ( state states -- state )
[ [ changed-locs>> ] keep untranslate-locs ] map assoc-combine
over translate-locs
>>changed-locs ;
:: insert-phis ( bb -- )
bb predecessors>> :> predecessors
[
added-phis get [| dst inputs |
dst predecessors inputs zip ##phi
] assoc-each
] V{ } make bb instructions>> over push-all
bb (>>instructions) ;
:: multiple-predecessors ( bb states -- state )
states [ not ] any? [
<state>
bb add-to-work-list
] [
[
H{ } clone added-instructions set
V{ } clone added-phis set
bb predecessors>> :> predecessors
state new
predecessors states merge-ds-heights
predecessors states merge-rs-heights
predecessors states merge-locs
states merge-actual-locs
states merge-changed-locs
bb insert-basic-blocks
bb insert-phis
] with-scope
] if ;
: merge-states ( bb states -- state )
dup length {
{ 0 [ initial-state ] }
{ 1 [ single-predecessor ] }
[ drop multiple-predecessors ]
} case ;

204
basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
View File

@ -1,204 +0,0 @@
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.rpo
compiler.cfg.dce compiler.cfg.registers
sets namespaces arrays cpu.architecture ;
IN: compiler.cfg.stack-analysis.tests
! Fundamental invariant: a basic block should not load or store a value more than once
: test-stack-analysis ( quot -- cfg )
dup cfg? [ test-cfg first ] unless
compute-predecessors
stack-analysis
dup check-cfg ;
: 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
[ t ] [
[ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
[ ##load-immediate? ] any?
] unit-test
! Correct height tracking
[ t ] [
[ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
reverse-post-order 4 swap nth
instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
2array { D 1 D 0 } set=
] unit-test
[ D 1 ] [
V{ T{ ##branch } } 0 test-bb
V{ T{ ##peek f V int-regs 0 D 2 } T{ ##branch } } 1 test-bb
V{
T{ ##peek f V int-regs 1 D 2 }
T{ ##inc-d f -1 }
T{ ##branch }
} 2 test-bb
V{ T{ ##call f \ + -1 } T{ ##branch } } 3 test-bb
V{ T{ ##return } } 4 test-bb
test-diamond
cfg new 0 get >>entry
compute-predecessors
stack-analysis
drop
3 get successors>> first instructions>> first loc>>
] unit-test
! Do inserted ##peeks reference the correct stack location if
! an ##inc-d/r was also inserted?
[ D 0 ] [
V{ T{ ##branch } } 0 test-bb
V{ T{ ##branch } } 1 test-bb
V{
T{ ##peek f V int-regs 1 D 0 }
T{ ##branch }
} 2 test-bb
V{
T{ ##call f \ + -1 }
T{ ##inc-d f 1 }
T{ ##branch }
} 3 test-bb
V{ T{ ##return } } 4 test-bb
test-diamond
cfg new 0 get >>entry
compute-predecessors
stack-analysis
drop
3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
] unit-test
! Missing ##replace
[ t ] [
[ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
reverse-post-order last
instructions>> [ ##replace? ] filter [ loc>> ] map
{ D 0 D 1 D 2 } set=
] unit-test
! Inserted ##peeks reference the wrong stack location
[ t ] [
[ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
eliminate-dead-code reverse-post-order 4 swap nth
instructions>> [ ##peek? ] filter [ loc>> ] map
{ D 0 D 1 } set=
] unit-test
[ D 0 ] [
V{ T{ ##branch } } 0 test-bb
V{ T{ ##branch } } 1 test-bb
V{
T{ ##peek f V int-regs 1 D 0 }
T{ ##inc-d f 1 }
T{ ##branch }
} 2 test-bb
V{
T{ ##inc-d f 1 }
T{ ##branch }
} 3 test-bb
V{ T{ ##return } } 4 test-bb
test-diamond
cfg new 0 get >>entry
compute-predecessors
stack-analysis
drop
3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
] unit-test

124
basis/compiler/cfg/stack-analysis/stack-analysis.factor
View File

@ -1,124 +0,0 @@
! 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 dlists deques
compiler.cfg
compiler.cfg.copy-prop
compiler.cfg.def-use
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.rpo
compiler.cfg.hats
compiler.cfg.stack-analysis.state
compiler.cfg.stack-analysis.merge
compiler.cfg.utilities ;
IN: compiler.cfg.stack-analysis
SYMBOL: global-optimization?
: redundant-replace? ( vreg loc -- ? )
dup state get untranslate-loc n>> 0 <
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
: save-changed-locs ( state -- )
[ changed-locs>> keys ] [ locs>vregs>> ] bi '[
dup _ at swap 2dup redundant-replace?
[ 2drop ] [ state get untranslate-loc ##replace ] if
] each ;
: sync-state ( -- )
state get {
[ ds-height>> save-ds-height ]
[ rs-height>> save-rs-height ]
[ save-changed-locs ]
[ clear-state ]
} cleave ;
! Abstract interpretation
GENERIC: visit ( insn -- )
M: ##inc-d visit
n>> state get [ + ] change-ds-height drop ;
M: ##inc-r visit
n>> state get [ + ] change-rs-height drop ;
! Instructions which don't have any effect on the stack
UNION: neutral-insn
##effect
##flushable
##no-tco ;
M: neutral-insn visit , ;
UNION: sync-if-back-edge
##branch
##conditional-branch
##compare-imm-branch
##dispatch
##loop-entry
##fixnum-overflow ;
: sync-state? ( -- ? )
basic-block get successors>>
[ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;
M: sync-if-back-edge visit
global-optimization? get [ sync-state? [ sync-state ] when ] unless
, ;
: eliminate-peek ( dst src -- )
! the requested stack location is already in 'src'
[ ##copy ] [ swap copies get set-at ] 2bi ;
M: ##peek visit
[ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg
[ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ;
M: ##replace visit
[ src>> resolve ] [ loc>> state get translate-loc ] bi
record-replace ;
M: ##copy visit
[ call-next-method ] [ record-copy ] bi ;
M: ##jump visit sync-state , ;
M: ##return visit sync-state , ;
M: ##callback-return visit sync-state , ;
M: kill-vreg-insn visit sync-state , ;
! Maps basic-blocks to states
SYMBOL: state-out
: block-in-state ( bb -- states )
dup predecessors>> state-out get '[ _ at ] map merge-states ;
: 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
state [
[ instructions>> [ visit ] each ]
[ [ state get ] dip set-block-out-state ]
[ ]
tri
] with-variable
] V{ } make >>instructions drop ;
: stack-analysis ( cfg -- cfg' )
[
<hashed-dlist> work-list set
H{ } clone copies set
H{ } clone state-out set
dup [ visit-block ] each-basic-block
global-optimization? get [ work-list get [ visit-block ] slurp-deque ] when
cfg-changed
] with-scope ;

53
basis/compiler/cfg/stack-analysis/state/state.factor
View File

@ -1,53 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets math deques
compiler.cfg.registers ;
IN: compiler.cfg.stack-analysis.state
TUPLE: state
locs>vregs actual-locs>vregs changed-locs
{ ds-height integer }
{ rs-height integer }
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 ;
: clear-state ( state -- )
0 >>ds-height 0 >>rs-height
[ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri
[ clear-assoc ] tri@ ;
GENERIC# translate-loc 1 ( loc state -- loc' )
M: ds-loc translate-loc [ n>> ] [ ds-height>> ] bi* - <ds-loc> ;
M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - <rs-loc> ;
GENERIC# untranslate-loc 1 ( loc state -- loc' )
M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + <ds-loc> ;
M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + <rs-loc> ;
SYMBOL: work-list
: add-to-work-list ( bb -- ) work-list get push-front ;

46
basis/compiler/cfg/dcn/rewrite/rewrite.factor → basis/compiler/cfg/stacks/finalize/finalize.factor
View File

@ -2,29 +2,20 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs kernel fry accessors sequences make math
combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.dcn.local
compiler.cfg.dcn.global compiler.cfg.dcn.height ;
IN: compiler.cfg.dcn.rewrite
compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.stacks.local
compiler.cfg.stacks.global compiler.cfg.stacks.height ;
IN: compiler.cfg.stacks.finalize
! This pass inserts peeks, replaces, and copies. All stack locations
! are loaded to canonical vregs, with a 1-1 mapping from location to
! vreg. SSA is reconstructed afterwards.
! This pass inserts peeks and replaces.
: inserting-peeks ( from to -- assoc )
peek-in swap [ peek-out ] [ avail-out ] bi
assoc-union assoc-diff ;
: remove-dead-stores ( assoc -- assoc' )
[ drop n>> 0 >= ] assoc-filter ;
: inserting-replaces ( from to -- assoc )
[ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi*
assoc-union assoc-diff ;
SYMBOL: locs>vregs
: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
: each-insertion ( assoc bb quot: ( vreg loc -- ) -- )
'[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline
@ -42,30 +33,9 @@ ERROR: bad-peek dst loc ;
2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make
[ 2drop ] [ <simple-block> insert-basic-block ] if-empty ;
: visit-edges ( bb -- )
: visit-block ( bb -- )
[ predecessors>> ] keep '[ _ visit-edge ] each ;
: insert-in-copies ( bb -- )
peek [ swap loc>vreg ##copy ] assoc-each ;
: insert-out-copies ( bb -- )
replace [ swap loc>vreg swap ##copy ] assoc-each ;
: rewrite-instructions ( bb -- )
[
[
{
[ insert-in-copies ]
[ instructions>> but-last-slice % ]
[ insert-out-copies ]
[ instructions>> last , ]
} cleave
] V{ } make
] keep (>>instructions) ;
: visit-block ( bb -- )
[ visit-edges ] [ rewrite-instructions ] bi ;
: rewrite ( cfg -- )
H{ } clone locs>vregs set
[ visit-block ] each-basic-block ;
: finalize-stack-shuffling ( cfg -- cfg' )
dup [ visit-block ] each-basic-block
cfg-changed ;

39
basis/compiler/cfg/stacks/global/global.factor Normal file
View File

@ -0,0 +1,39 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel combinators compiler.cfg.dataflow-analysis
compiler.cfg.stacks.local ;
IN: compiler.cfg.stacks.global
! Peek analysis. Peek-in is the set of all locations anticipated at
! the start of a basic block.
BACKWARD-ANALYSIS: peek
M: peek-analysis transfer-set drop [ replace-set assoc-diff ] keep peek-set assoc-union ;
! Replace analysis. Replace-in is the set of all locations which
! will be overwritten at some point after the start of a basic block.
FORWARD-ANALYSIS: replace
M: replace-analysis transfer-set drop replace-set assoc-union ;
! Availability analysis. Avail-out is the set of all locations
! in registers at the end of a basic block.
FORWARD-ANALYSIS: avail
M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union assoc-union ;
! Kill analysis. Kill-in is the set of all locations
! which are going to be overwritten.
BACKWARD-ANALYSIS: kill
M: kill-analysis transfer-set drop replace-set assoc-union ;
! Main word
: compute-global-sets ( cfg -- cfg' )
{
[ compute-peek-sets ]
[ compute-replace-sets ]
[ compute-avail-sets ]
[ compute-kill-sets ]
[ ]
} cleave ;

27
basis/compiler/cfg/stacks/height/height.factor Normal file
View File

@ -0,0 +1,27 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel math
namespaces compiler.cfg.registers ;
IN: compiler.cfg.stacks.height
! Global stack height tracking done while constructing CFG.
SYMBOLS: ds-heights rs-heights ;
: record-stack-heights ( ds-height rs-height bb -- )
[ ds-heights get set-at ] [ rs-heights get set-at ] bi-curry bi* ;
GENERIC# translate-loc 1 ( loc bb -- loc' )
M: ds-loc translate-loc [ n>> ] [ ds-heights get at ] bi* - <ds-loc> ;
M: rs-loc translate-loc [ n>> ] [ rs-heights get at ] bi* - <rs-loc> ;
: translate-locs ( assoc bb -- assoc' )
'[ [ _ translate-loc ] dip ] assoc-map ;
GENERIC# untranslate-loc 1 ( loc bb -- loc' )
M: ds-loc untranslate-loc [ n>> ] [ ds-heights get at ] bi* + <ds-loc> ;
M: rs-loc untranslate-loc [ n>> ] [ rs-heights get at ] bi* + <rs-loc> ;
: untranslate-locs ( assoc bb -- assoc' )
'[ [ _ untranslate-loc ] dip ] assoc-map ;

91
basis/compiler/cfg/stacks/local/local.factor Normal file
View File

@ -0,0 +1,91 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math namespaces sets make sequences
compiler.cfg
compiler.cfg.hats
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.stacks.height
compiler.cfg.parallel-copy ;
IN: compiler.cfg.stacks.local
! Local stack analysis. We build local peek and replace sets for every basic
! block while constructing the CFG.
SYMBOLS: peek-sets replace-sets ;
SYMBOL: locs>vregs
: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ;
SYMBOLS: local-peek-set local-replace-set replace-mapping ;
GENERIC: translate-local-loc ( loc -- loc' )
M: ds-loc translate-local-loc n>> current-height get d>> - <ds-loc> ;
M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
: emit-stack-changes ( -- )
replace-mapping get dup assoc-empty? [ drop ] [
[ [ loc>vreg ] dip ] assoc-map parallel-copy
] if ;
: emit-height-changes ( -- )
current-height get
[ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ]
[ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi ;
: emit-changes ( -- )
! Insert height and stack changes prior to the last instruction
building get pop
emit-stack-changes
emit-height-changes
, ;
! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later
: inc-d ( n -- )
current-height get
[ [ + ] change-emit-d drop ]
[ [ + ] change-d drop ]
2bi ;
: inc-r ( n -- )
current-height get
[ [ + ] change-emit-r drop ]
[ [ + ] change-r drop ]
2bi ;
: peek-loc ( loc -- vreg )
translate-local-loc
dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless
dup replace-mapping get at [ ] [ loc>vreg ] ?if ;
: replace-loc ( vreg loc -- )
translate-local-loc
2dup loc>vreg =
[ nip replace-mapping get delete-at ]
[
[ local-replace-set get conjoin ]
[ replace-mapping get set-at ]
bi
] if ;
: begin-local-analysis ( -- )
H{ } clone local-peek-set set
H{ } clone local-replace-set set
H{ } clone replace-mapping set
current-height get 0 >>emit-d 0 >>emit-r drop
current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ;
: end-local-analysis ( -- )
emit-changes
local-peek-set get basic-block get peek-sets get set-at
local-replace-set get basic-block get replace-sets get set-at ;
: clone-current-height ( -- )
current-height [ clone ] change ;
: peek-set ( bb -- assoc ) peek-sets get at ;
: replace-set ( bb -- assoc ) replace-sets get at ;

67
basis/compiler/cfg/stacks/stacks.factor
View File

@ -1,45 +1,76 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math sequences kernel cpu.architecture
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.hats ;
USING: math sequences kernel namespaces accessors biassocs compiler.cfg
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats
compiler.cfg.predecessors compiler.cfg.stacks.local
compiler.cfg.stacks.height compiler.cfg.stacks.global
compiler.cfg.stacks.finalize ;
IN: compiler.cfg.stacks
: ds-drop ( -- )
-1 ##inc-d ;
: begin-stack-analysis ( -- )
<bihash> locs>vregs set
H{ } clone ds-heights set
H{ } clone rs-heights set
H{ } clone peek-sets set
H{ } clone replace-sets set
current-height new current-height set ;
: ds-pop ( -- vreg )
D 0 ^^peek -1 ##inc-d ;
: end-stack-analysis ( -- )
cfg get
compute-predecessors
compute-global-sets
finalize-stack-shuffling
drop ;
: ds-push ( vreg -- )
1 ##inc-d D 0 ##replace ;
: ds-drop ( -- ) -1 inc-d ;
: ds-peek ( -- vreg ) D 0 peek-loc ;
: ds-pop ( -- vreg ) ds-peek ds-drop ;
: ds-push ( vreg -- ) 1 inc-d D 0 replace-loc ;
: ds-load ( n -- vregs )
dup 0 =
[ drop f ]
[ [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ] if ;
[ [ <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
: ds-store ( vregs -- )
[
<reversed>
[ length ##inc-d ]
[ [ <ds-loc> ##replace ] each-index ] bi
[ length inc-d ]
[ [ <ds-loc> replace-loc ] each-index ] bi
] unless-empty ;
: rs-drop ( -- ) -1 inc-r ;
: rs-load ( n -- vregs )
dup 0 =
[ drop f ]
[ [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ] if ;
[ [ <reversed> [ <rs-loc> peek-loc ] map ] [ neg inc-r ] bi ] if ;
: rs-store ( vregs -- )
[
<reversed>
[ length ##inc-r ]
[ [ <rs-loc> ##replace ] each-index ] bi
[ length inc-r ]
[ [ <rs-loc> replace-loc ] each-index ] bi
] unless-empty ;
: (2inputs) ( -- vreg1 vreg2 )
D 1 peek-loc D 0 peek-loc ;
: 2inputs ( -- vreg1 vreg2 )
D 1 ^^peek D 0 ^^peek -2 ##inc-d ;
(2inputs) -2 inc-d ;
: (3inputs) ( -- vreg1 vreg2 vreg3 )
D 2 peek-loc D 1 peek-loc D 0 peek-loc ;
: 3inputs ( -- vreg1 vreg2 vreg3 )
D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ;
(3inputs) -3 inc-d ;
! adjust-d/adjust-r: these are called when other instructions which
! internally adjust the stack height are emitted, such as ##call and
! ##alien-invoke
: adjust-d ( n -- ) current-height get [ + ] change-d drop ;
: adjust-r ( n -- ) current-height get [ + ] change-r drop ;

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 ;

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

@ -20,42 +20,6 @@ IN: compiler.cfg.utilities
} cond
] [ drop f ] if ;
: set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi ;
: begin-basic-block ( -- )
<basic-block> basic-block get [
dupd successors>> push
] when*
set-basic-block ;
: end-basic-block ( -- )
building off
basic-block off ;
: emit-trivial-block ( quot -- )
basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless
call
##branch begin-basic-block ; inline
: call-height ( #call -- n )
[ out-d>> length ] [ in-d>> length ] bi - ;
: emit-primitive ( node -- )
[ [ word>> ] [ call-height ] bi ##call ] emit-trivial-block ;
: with-branch ( quot -- final-bb )
[
begin-basic-block
call
basic-block get dup [ ##branch ] when
] with-scope ; inline
: emit-conditional ( branches -- )
end-basic-block
begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each ;
PREDICATE: kill-block < basic-block
instructions>> {
[ length 2 = ]
@ -84,16 +48,6 @@ SYMBOL: visited
: skip-empty-blocks ( bb -- bb' )
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
! assoc mapping predecessors to sequences
SYMBOL: added-instructions
: add-instructions ( predecessor quot -- )
[
added-instructions get
[ drop V{ } clone ] cache
building
] dip with-variable ; inline
:: insert-basic-block ( from to bb -- )
bb from 1vector >>predecessors drop
bb to 1vector >>successors drop
@ -105,7 +59,3 @@ SYMBOL: added-instructions
swap >vector
\ ##branch new-insn over push
>>instructions ;
: insert-basic-blocks ( bb -- )
[ added-instructions get ] dip
'[ [ _ ] dip <simple-block> insert-basic-block ] assoc-each ;

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 ;

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

@ -20,13 +20,9 @@ IN: compiler.cfg.value-numbering.rewrite
! Outputs f to mean no change
GENERIC: rewrite* ( insn -- insn/f )
GENERIC: rewrite ( insn -- insn/f )
: rewrite ( insn -- insn' )
dup [ number-values ] [ rewrite* ] bi
[ rewrite ] [ ] ?if ;
M: insn rewrite* drop f ;
M: insn rewrite drop f ;
: ##branch-t? ( insn -- ? )
dup ##compare-imm-branch? [
@ -123,7 +119,7 @@ ERROR: bad-comparison ;
: fold-compare-imm-branch ( insn -- insn/f )
(fold-compare-imm) fold-branch ;
M: ##compare-imm-branch rewrite*
M: ##compare-imm-branch rewrite
{
{ [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
{ [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
@ -154,7 +150,7 @@ M: ##compare-imm-branch rewrite*
: rewrite-self-compare-branch ( insn -- insn' )
(rewrite-self-compare) fold-branch ;
M: ##compare-branch rewrite*
M: ##compare-branch rewrite
{
{ [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] }
{ [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] }
@ -185,7 +181,7 @@ M: ##compare-branch rewrite*
: rewrite-self-compare ( insn -- insn' )
dup (rewrite-self-compare) >boolean-insn ;
M: ##compare rewrite*
M: ##compare rewrite
{
{ [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] }
{ [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] }
@ -196,7 +192,7 @@ M: ##compare rewrite*
: fold-compare-imm ( insn -- insn' )
dup (fold-compare-imm) >boolean-insn ;
M: ##compare-imm rewrite*
M: ##compare-imm rewrite
{
{ [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
{ [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
@ -238,7 +234,7 @@ M: ##shl-imm constant-fold* drop shift ;
] dip
over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline
M: ##add-imm rewrite*
M: ##add-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##add-imm reassociate ] }
@ -249,7 +245,7 @@ M: ##add-imm rewrite*
[ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
[ \ ##add-imm new-insn ] [ 3drop f ] if ;
M: ##sub-imm rewrite*
M: ##sub-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
[ sub-imm>add-imm ]
@ -261,7 +257,7 @@ M: ##sub-imm rewrite*
: strength-reduce-mul? ( insn -- ? )
src2>> power-of-2? ;
M: ##mul-imm rewrite*
M: ##mul-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
@ -269,40 +265,40 @@ M: ##mul-imm rewrite*
[ drop f ]
} cond ;
M: ##and-imm rewrite*
M: ##and-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##and-imm reassociate ] }
[ drop f ]
} cond ;
M: ##or-imm rewrite*
M: ##or-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##or-imm reassociate ] }
[ drop f ]
} cond ;
M: ##xor-imm rewrite*
M: ##xor-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##xor-imm reassociate ] }
[ drop f ]
} cond ;
M: ##shl-imm rewrite*
M: ##shl-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
[ drop f ]
} cond ;
M: ##shr-imm rewrite*
M: ##shr-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
[ drop f ]
} cond ;
M: ##sar-imm rewrite*
M: ##sar-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
[ drop f ]
@ -327,7 +323,7 @@ M: ##sar-imm rewrite*
[ 2drop f ]
} cond ; inline
M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ;
M: ##add rewrite \ ##add-imm rewrite-arithmetic-commutative ;
: subtraction-identity? ( insn -- ? )
[ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ;
@ -335,22 +331,22 @@ M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ;
: rewrite-subtraction-identity ( insn -- insn' )
dst>> 0 \ ##load-immediate new-insn ;
M: ##sub rewrite*
M: ##sub rewrite
{
{ [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
[ \ ##sub-imm rewrite-arithmetic ]
} cond ;
M: ##mul rewrite* \ ##mul-imm rewrite-arithmetic-commutative ;
M: ##mul rewrite \ ##mul-imm rewrite-arithmetic-commutative ;
M: ##and rewrite* \ ##and-imm rewrite-arithmetic-commutative ;
M: ##and rewrite \ ##and-imm rewrite-arithmetic-commutative ;
M: ##or rewrite* \ ##or-imm rewrite-arithmetic-commutative ;
M: ##or rewrite \ ##or-imm rewrite-arithmetic-commutative ;
M: ##xor rewrite* \ ##xor-imm rewrite-arithmetic-commutative ;
M: ##xor rewrite \ ##xor-imm rewrite-arithmetic-commutative ;
M: ##shl rewrite* \ ##shl-imm rewrite-arithmetic ;
M: ##shl rewrite \ ##shl-imm rewrite-arithmetic ;
M: ##shr rewrite* \ ##shr-imm rewrite-arithmetic ;
M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ;
M: ##sar rewrite* \ ##sar-imm rewrite-arithmetic ;
M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;

6
basis/compiler/cfg/value-numbering/simplify/simplify.factor
View File

@ -127,7 +127,5 @@ M: expr simplify* drop f ;
{ [ dup integer? ] [ nip ] }
} cond ;
GENERIC: number-values ( insn -- )
M: ##flushable number-values [ >expr simplify ] [ dst>> ] bi set-vn ;
M: insn number-values drop ;
: number-values ( insn -- )
[ >expr simplify ] [ dst>> ] bi set-vn ;

185
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,15 +29,15 @@ 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
[
{
T{ ##load-reference f V int-regs 0 0.0 }
T{ ##load-reference f V int-regs 1 0.0 }
T{ ##copy f V int-regs 1 V int-regs 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##replace f V int-regs 0 D 1 }
T{ ##replace f V int-regs 1 D 1 }
}
] [
{
@ -49,15 +45,15 @@ 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
[
{
T{ ##load-reference f V int-regs 0 t }
T{ ##load-reference f V int-regs 1 t }
T{ ##copy f V int-regs 1 V int-regs 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##replace f V int-regs 0 D 1 }
T{ ##replace f V int-regs 1 D 1 }
}
] [
{
@ -65,22 +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
] unit-test
! Copy propagation
[
{
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 45 7 cc/= }
}
] [
{
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
@ -89,8 +70,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
T{ ##replace f V int-regs 4 D 0 }
T{ ##copy f V int-regs 6 V int-regs 4 }
T{ ##replace f V int-regs 6 D 0 }
}
] [
{
@ -99,7 +80,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 +98,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 +120,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 +136,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 +151,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 +165,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 +179,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 +191,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 +205,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 +219,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 +231,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 +245,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 +259,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 +273,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 +287,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 +301,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 +315,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 +329,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 +343,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 +357,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 +371,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 +390,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 +408,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 +426,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 +444,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 +462,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 +480,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 +498,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 +516,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 +534,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 +552,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 +570,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 +588,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
@ -616,8 +597,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f V int-regs 1 D 1 }
T{ ##load-immediate f V int-regs 2 0 }
T{ ##add-imm f V int-regs 3 V int-regs 0 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##copy f V int-regs 3 V int-regs 0 }
T{ ##replace f V int-regs 3 D 0 }
}
] [
{
@ -626,7 +607,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
[
@ -634,8 +615,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f V int-regs 1 D 1 }
T{ ##load-immediate f V int-regs 2 0 }
T{ ##add-imm f V int-regs 3 V int-regs 0 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##copy f V int-regs 3 V int-regs 0 }
T{ ##replace f V int-regs 3 D 0 }
}
] [
{
@ -644,7 +625,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
[
@ -652,8 +633,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f V int-regs 1 D 1 }
T{ ##load-immediate f V int-regs 2 0 }
T{ ##or-imm f V int-regs 3 V int-regs 0 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##copy f V int-regs 3 V int-regs 0 }
T{ ##replace f V int-regs 3 D 0 }
}
] [
{
@ -662,7 +643,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
[
@ -670,8 +651,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f V int-regs 1 D 1 }
T{ ##load-immediate f V int-regs 2 0 }
T{ ##xor-imm f V int-regs 3 V int-regs 0 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##copy f V int-regs 3 V int-regs 0 }
T{ ##replace f V int-regs 3 D 0 }
}
] [
{
@ -680,15 +661,15 @@ 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
[
{
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 2 V int-regs 0 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##copy f V int-regs 2 V int-regs 0 }
T{ ##replace f V int-regs 2 D 0 }
}
] [
{
@ -696,7 +677,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 +694,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 +710,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 +726,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 +742,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 +758,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 +774,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 +788,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 +803,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 +818,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 +835,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 +849,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 +865,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 +881,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 +895,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 +909,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 +923,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 +935,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 +947,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 +959,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 +971,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 +983,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 +995,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 +1189,6 @@ test-diamond
[ ] [
cfg new 0 get >>entry
compute-liveness
value-numbering
compute-predecessors
eliminate-phis drop
@ -1253,7 +1233,6 @@ test-diamond
[ ] [
cfg new 0 get >>entry
compute-predecessors
compute-liveness
value-numbering
compute-predecessors
eliminate-dead-code
@ -1324,7 +1303,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

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

@ -1,11 +1,10 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs biassocs classes kernel math accessors
sorting sets sequences fry
USING: namespaces assocs kernel accessors
sorting sets sequences
compiler.cfg
compiler.cfg.local
compiler.cfg.liveness
compiler.cfg.renaming
compiler.cfg.rpo
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions
compiler.cfg.value-numbering.simplify
@ -13,27 +12,28 @@ compiler.cfg.value-numbering.rewrite ;
IN: compiler.cfg.value-numbering
! Local value numbering. Predecessors must be recomputed after this
: >copy ( insn -- insn/##copy )
dup dst>> dup vreg>vn vn>vreg
2dup eq? [ 2drop ] [ \ ##copy new-insn nip ] if ;
: number-input-values ( live-in -- )
[ [ f next-input-expr simplify ] dip set-vn ] each ;
: rewrite-loop ( insn -- insn' )
dup rewrite [ rewrite-loop ] [ ] ?if ;
: init-value-numbering ( live-in -- )
init-value-graph
init-expressions
number-input-values ;
GENERIC: process-instruction ( insn -- insn' )
: vreg>vreg-mapping ( -- assoc )
vregs>vns get [ keys ] keep
'[ dup _ [ at ] [ value-at ] bi ] H{ } map>assoc ;
M: ##flushable process-instruction
dup rewrite
[ process-instruction ]
[ dup number-values >copy ] ?if ;
: rename-uses ( insns -- )
vreg>vreg-mapping renamings [
[ rename-insn-uses ] each
] with-variable ;
M: insn process-instruction
dup rewrite
[ process-instruction ] [ ] ?if ;
: value-numbering-step ( insns -- insns' )
[ rewrite ] map dup rename-uses ;
init-value-graph
init-expressions
[ process-instruction ] map ;
: value-numbering ( cfg -- cfg' )
[ init-value-numbering ] [ value-numbering-step ] local-optimization
cfg-changed ;
[ value-numbering-step ] local-optimization cfg-changed ;

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

@ -1,42 +1,43 @@
USING: compiler.cfg.write-barrier compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
arrays tools.test vectors compiler.cfg kernel accessors ;
arrays tools.test vectors compiler.cfg kernel accessors
compiler.cfg.utilities ;
IN: compiler.cfg.write-barrier.tests
: test-write-barrier ( insns -- insns )
write-barriers-step ;
<simple-block> dup write-barriers-step instructions>> ;
[
{
V{
T{ ##peek f V int-regs 4 D 0 f }
T{ ##copy f V int-regs 6 V int-regs 4 f }
T{ ##allot f V int-regs 7 24 array V int-regs 8 f }
T{ ##load-immediate f V int-regs 9 8 f }
T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f }
T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 f }
T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 f }
T{ ##replace f V int-regs 7 D 0 f }
T{ ##branch }
}
] [
{
T{ ##peek f V int-regs 4 D 0 }
T{ ##copy f V int-regs 6 V int-regs 4 }
T{ ##allot f V int-regs 7 24 array V int-regs 8 }
T{ ##load-immediate f V int-regs 9 8 }
T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 }
T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 }
T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 }
T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 }
T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
T{ ##replace f V int-regs 7 D 0 }
} test-write-barrier
] unit-test
[
{
V{
T{ ##load-immediate f V int-regs 4 24 }
T{ ##peek f V int-regs 5 D -1 }
T{ ##peek f V int-regs 6 D -2 }
T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
T{ ##branch }
}
] [
{
@ -49,28 +50,23 @@ IN: compiler.cfg.write-barrier.tests
] unit-test
[
{
V{
T{ ##peek f V int-regs 19 D -3 }
T{ ##peek f V int-regs 22 D -2 }
T{ ##copy f V int-regs 23 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
T{ ##copy f V int-regs 26 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 }
T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 }
T{ ##peek f V int-regs 28 D -1 }
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 19 4 2 }
T{ ##branch }
}
] [
{
T{ ##peek f V int-regs 19 D -3 }
T{ ##peek f V int-regs 22 D -2 }
T{ ##copy f V int-regs 23 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
T{ ##copy f V int-regs 26 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 }
T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 }
T{ ##peek f V int-regs 28 D -1 }
T{ ##copy f V int-regs 29 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 }
T{ ##write-barrier f V int-regs 19 V int-regs 30 V int-regs 3 }
} test-write-barrier
] unit-test

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

@ -1,8 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences locals
compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop
compiler.cfg.liveness compiler.cfg.local ;
USING: kernel accessors namespaces assocs sets sequences
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits.
@ -14,33 +13,27 @@ SYMBOL: safe
! Objects which have been mutated
SYMBOL: mutated
GENERIC: eliminate-write-barrier ( insn -- insn' )
GENERIC: eliminate-write-barrier ( insn -- ? )
M: ##allot eliminate-write-barrier
dup dst>> safe get conjoin ;
dst>> safe get conjoin t ;
M: ##write-barrier eliminate-write-barrier
dup src>> resolve dup
[ safe get key? not ]
[ mutated get key? ] bi and
[ safe get conjoin ] [ 2drop f ] if ;
M: ##copy eliminate-write-barrier
dup record-copy ;
src>> dup [ safe get key? not ] [ mutated get key? ] bi and
[ safe get conjoin t ] [ drop f ] if ;
M: ##set-slot eliminate-write-barrier
dup obj>> resolve mutated get conjoin ;
obj>> mutated get conjoin t ;
M: ##set-slot-imm eliminate-write-barrier
dup obj>> resolve mutated get conjoin ;
obj>> mutated get conjoin t ;
M: insn eliminate-write-barrier ;
M: insn eliminate-write-barrier drop t ;
: write-barriers-step ( insns -- insns' )
: write-barriers-step ( bb -- )
H{ } clone safe set
H{ } clone mutated set
H{ } clone copies set
[ eliminate-write-barrier ] map sift ;
instructions>> [ eliminate-write-barrier ] filter-here ;
: eliminate-write-barriers ( cfg -- cfg' )
[ drop ] [ write-barriers-step ] local-optimization ;
dup [ write-barriers-step ] each-basic-block ;

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

@ -245,7 +245,7 @@ M: _gc generate-insn
[ gc-root-count>> ]
} cleave %gc ;
M: ##loop-entry generate-insn drop %loop-entry ;
M: _loop-entry generate-insn drop %loop-entry ;
M: ##alien-global generate-insn
[ dst>> register ] [ symbol>> ] [ library>> ] tri

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

@ -286,7 +286,7 @@ M: cucumber equal? "The cucumber has no equal" throw ;
[ 4294967295 B{ 255 255 255 255 } -1 ]
[
-1 <int> -1 <int>
[ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ]
[ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ]
compile-call
] unit-test
@ -321,4 +321,16 @@ cell 4 = [
] when
! Regression from Slava's value numbering changes
[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test
! Bug with ##return node construction
: return-recursive-bug ( nodes -- ? )
{ fixnum } declare [
dup 3 bitand 1 = [ drop t ] [
dup 3 bitand 2 = [
return-recursive-bug
] [ drop f ] if
] if
] any? ; inline recursive
[ t ] [ 3 [ return-recursive-bug ] compile-call ] unit-test

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: `: }

13
basis/math/bitwise/bitwise.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math sequences accessors
math.bits sequences.private words namespaces macros
hints combinators fry io.binary combinators.smart ;
USING: arrays assocs combinators combinators.smart fry kernel
macros math math.bits sequences sequences.private words ;
IN: math.bitwise
! utilities
@ -104,14 +103,6 @@ PRIVATE>
: bit-count ( x -- n )
dup 0 < [ bitnot ] when (bit-count) ; inline
! Signed byte array to integer conversion
: signed-le> ( bytes -- x )
[ le> ] [ length 8 * 1 - on-bits ] bi
2dup > [ bitnot bitor ] [ drop ] if ;
: signed-be> ( bytes -- x )
<reversed> signed-le> ;
: >signed ( x n -- y )
2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;

8
basis/opengl/capabilities/capabilities-docs.factor
View File

@ -40,7 +40,13 @@ HELP: gl-extensions
HELP: has-gl-extensions?
{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } ". Elements of " { $snippet "extensions" } " can be sequences, in which case true will be returned if any one of the extensions in the subsequence are available." }
{ $examples "Testing for framebuffer object and pixel buffer support:"
{ $code <" {
{ "GL_EXT_framebuffer_object" "GL_ARB_framebuffer_object" }
"GL_ARB_pixel_buffer_object"
} has-gl-extensions? "> }
} ;
HELP: has-gl-version-or-extensions?
{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } }

21
basis/opengl/capabilities/capabilities-tests.factor Normal file
View File

@ -0,0 +1,21 @@
! (c)2009 Joe Groff bsd license
USING: opengl.capabilities tools.test ;
IN: opengl.capabilities.tests
CONSTANT: test-extensions
{
"GL_ARB_vent_core_frogblast"
"GL_EXT_resonance_cascade"
"GL_EXT_slipgate"
}
[ t ]
[ "GL_ARB_vent_core_frogblast" test-extensions (has-extension?) ] unit-test
[ f ]
[ "GL_ARB_wallhack" test-extensions (has-extension?) ] unit-test
[ t ] [
{ "GL_EXT_dimensional_portal" "GL_EXT_slipgate" }
test-extensions (has-extension?)
] unit-test

7
basis/opengl/capabilities/capabilities.factor
View File

@ -1,16 +1,19 @@
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces make sequences splitting opengl.gl
continuations math.parser math arrays sets math.order fry ;
continuations math.parser math arrays sets strings math.order fry ;
IN: opengl.capabilities
: (require-gl) ( thing require-quot make-error-quot -- )
[ dupd call [ drop ] ] dip '[ _ " " make throw ] if ; inline
: (has-extension?) ( query-extension(s) available-extensions -- ? )
over string? [ member? ] [ [ member? ] curry any? ] if ;
: gl-extensions ( -- seq )
GL_EXTENSIONS glGetString " " split ;
: has-gl-extensions? ( extensions -- ? )
gl-extensions swap [ over member? ] all? nip ;
gl-extensions [ (has-extension?) ] curry all? ;
: (make-gl-extensions-error) ( required-extensions -- )
gl-extensions diff
"Required OpenGL extensions not supported:\n" %

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>

2
basis/x11/xlib/xlib.factor
View File

@ -477,7 +477,7 @@ C-STRUCT: XImage
{ "XImage-funcs" "f" } ;
X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
X-FUNCTION: int XDestroyImage ( XImage *ximage ) ;
X-FUNCTION: int XDestroyImage ( XImage* ximage ) ;
: XImage-size ( ximage -- size )
[ XImage-height ] [ XImage-bytes_per_line ] bi * ;

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 ;

7
core/io/binary/binary.factor
View File

@ -24,3 +24,10 @@ IN: io.binary
: h>b/b ( h -- b1 b2 )
[ mask-byte ]
[ -8 shift mask-byte ] bi ;
: signed-le> ( bytes -- x )
[ le> ] [ length 8 * 1 - 2^ 1 - ] bi
2dup > [ bitnot bitor ] [ drop ] if ;
: signed-be> ( bytes -- x )
<reversed> signed-le> ;

1
extra/alien/cxx/authors.txt Normal file
View File

@ -0,0 +1 @@
Jeremy Hughes

34
extra/alien/cxx/cxx.factor Normal file
View File

@ -0,0 +1,34 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.cxx.parser alien.marshall
alien.inline.types classes.mixin classes.tuple kernel namespaces
assocs sequences parser classes.parser alien.marshall.syntax
interpolate locals effects io strings make vocabs.parser words
generic fry quotations ;
IN: alien.cxx
<PRIVATE
: class-mixin ( str -- word )
create-class-in [ define-mixin-class ] keep ;
: class-tuple-word ( word -- word' )
"#" append create-in ;
: define-class-tuple ( word mixin -- )
[ drop class-wrapper { } define-tuple-class ]
[ add-mixin-instance ] 2bi ;
PRIVATE>
: define-c++-class ( name superclass-mixin -- )
[ [ class-tuple-word ] [ class-mixin ] bi dup ] dip
add-mixin-instance define-class-tuple ;
:: define-c++-method ( class-name generic name types effect virtual -- )
[ name % "_" % class-name { { CHAR: : CHAR: _ } } substitute % ] "" make :> name'
effect [ in>> "self" suffix ] [ out>> ] bi <effect> :> effect'
types class-name "*" append suffix :> types'
effect in>> "," join :> args
class-name virtual [ "#" append ] unless current-vocab lookup :> class
SBUF" " clone dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body
name' types' effect' body define-c-marshalled
class generic create-method name' current-vocab lookup 1quotation define ;

1
extra/alien/cxx/parser/authors.txt Normal file
View File

@ -0,0 +1 @@
Jeremy Hughes

10
extra/alien/cxx/parser/parser.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: parser lexer alien.inline ;
IN: alien.cxx.parser
: parse-c++-class-definition ( -- class superclass-mixin )
scan scan-word ;
: parse-c++-method-definition ( -- class-name generic name types effect )
scan scan-word function-types-effect ;

1
extra/alien/cxx/syntax/authors.txt Normal file
View File

@ -0,0 +1 @@
Jeremy Hughes

113
extra/alien/cxx/syntax/syntax-tests.factor Normal file
View File

@ -0,0 +1,113 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test alien.cxx.syntax alien.inline.syntax
alien.marshall.syntax alien.marshall accessors kernel ;
IN: alien.cxx.syntax.tests
DELETE-C-LIBRARY: test
C-LIBRARY: test
COMPILE-AS-C++
C-INCLUDE: <string>
C-TYPEDEF: std::string string
C++-CLASS: std::string c++-root
GENERIC: to-string ( obj -- str )
C++-METHOD: std::string to-string const-char* c_str ( )
CM-FUNCTION: std::string* new_string ( const-char* s )
return new std::string(s);
;
;C-LIBRARY
ALIAS: <std::string> new_string
{ 1 1 } [ new_string ] must-infer-as
{ 1 1 } [ c_str_std__string ] must-infer-as
[ t ] [ "abc" <std::string> std::string? ] unit-test
[ "abc" ] [ "abc" <std::string> to-string ] unit-test
DELETE-C-LIBRARY: inheritance
C-LIBRARY: inheritance
COMPILE-AS-C++
C-INCLUDE: <cstring>
RAW-C:
class alpha {
public:
alpha(const char* s) {
str = s;
};
const char* render() {
return str;
};
virtual const char* chop() {
return str;
};
virtual int length() {
return strlen(str);
};
const char* str;
};
class beta : alpha {
public:
beta(const char* s) : alpha(s + 1) { };
const char* render() {
return str + 1;
};
virtual const char* chop() {
return str + 2;
};
};
;
C++-CLASS: alpha c++-root
C++-CLASS: beta alpha
CM-FUNCTION: alpha* new_alpha ( const-char* s )
return new alpha(s);
;
CM-FUNCTION: beta* new_beta ( const-char* s )
return new beta(s);
;
ALIAS: <alpha> new_alpha
ALIAS: <beta> new_beta
GENERIC: render ( obj -- obj )
GENERIC: chop ( obj -- obj )
GENERIC: length ( obj -- n )
C++-METHOD: alpha render const-char* render ( )
C++-METHOD: beta render const-char* render ( )
C++-VIRTUAL: alpha chop const-char* chop ( )
C++-VIRTUAL: beta chop const-char* chop ( )
C++-VIRTUAL: alpha length int length ( )
;C-LIBRARY
{ 1 1 } [ render_alpha ] must-infer-as
{ 1 1 } [ chop_beta ] must-infer-as
{ 1 1 } [ length_alpha ] must-infer-as
[ t ] [ "x" <alpha> alpha#? ] unit-test
[ t ] [ "x" <alpha> alpha? ] unit-test
[ t ] [ "x" <beta> alpha? ] unit-test
[ f ] [ "x" <beta> alpha#? ] unit-test
[ 5 ] [ "hello" <alpha> length ] unit-test
[ 4 ] [ "hello" <beta> length ] unit-test
[ "hello" ] [ "hello" <alpha> render ] unit-test
[ "llo" ] [ "hello" <beta> render ] unit-test
[ "ello" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying render ] unit-test
[ "hello" ] [ "hello" <alpha> chop ] unit-test
[ "lo" ] [ "hello" <beta> chop ] unit-test
[ "lo" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying chop ] unit-test

13
extra/alien/cxx/syntax/syntax.factor Normal file
View File

@ -0,0 +1,13 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.cxx alien.cxx.parser ;
IN: alien.cxx.syntax
SYNTAX: C++-CLASS:
parse-c++-class-definition define-c++-class ;
SYNTAX: C++-METHOD:
parse-c++-method-definition f define-c++-method ;
SYNTAX: C++-VIRTUAL:
parse-c++-method-definition t define-c++-method ;

44
extra/alien/inline/types/types.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types assocs combinators.short-circuit
continuations effects fry kernel math memoize sequences
splitting ;
splitting strings peg.ebnf make ;
IN: alien.inline.types
: cify-type ( str -- str' )
@ -21,6 +21,9 @@ IN: alien.inline.types
: pointer-to-const? ( str -- ? )
cify-type "const " head? ;
: template-class? ( str -- ? )
[ CHAR: < = ] any? ;
MEMO: resolved-primitives ( -- seq )
primitive-types [ resolve-typedef ] map ;
@ -57,3 +60,42 @@ MEMO: resolved-primitives ( -- seq )
[ over pointer-to-primitive? [ ">" prepend ] when ]
assoc-map unzip
] dip <effect> ;
TUPLE: c++-type name params ptr ;
C: <c++-type> c++-type
EBNF: (parse-c++-type)
dig = [0-9]
alpha = [a-zA-Z]
alphanum = [1-9a-zA-Z]
name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]]
ptr = [*&] => [[ empty? not ]]
param = "," " "* type " "* => [[ third ]]
params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]]
type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 <c++-type> ]]
;EBNF
: parse-c++-type ( str -- c++-type )
factorize-type (parse-c++-type) ;
DEFER: c++-type>string
: params>string ( params -- str )
[ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ;
: c++-type>string ( c++-type -- str )
[
[ name>> % ]
[ params>> [ params>string % ] when* ]
[ ptr>> [ "*" % ] when ]
tri
] "" make ;
GENERIC: c++-type ( obj -- c++-type/f )
M: object c++-type drop f ;
M: c++-type c-type ;

2
extra/alien/marshall/marshall-docs.factor
View File

@ -327,7 +327,7 @@ HELP: out-arg-unmarshaller
"for all types except pointers to non-const primitives."
} ;
HELP: pointer-unmarshaller
HELP: class-unmarshaller
{ $values
{ "type" " a C type string" }
{ "quot" quotation }

62
extra/alien/marshall/marshall.factor
View File

@ -11,7 +11,8 @@ specialized-arrays.long specialized-arrays.longlong
specialized-arrays.short specialized-arrays.uchar
specialized-arrays.uint specialized-arrays.ulong
specialized-arrays.ulonglong specialized-arrays.ushort strings
unix.utilities vocabs.parser words libc.private struct-arrays ;
unix.utilities vocabs.parser words libc.private struct-arrays
locals generalizations math ;
IN: alien.marshall
<< primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
@ -19,6 +20,9 @@ filter [ define-primitive-marshallers ] each >>
TUPLE: alien-wrapper { underlying alien } ;
TUPLE: struct-wrapper < alien-wrapper disposed ;
TUPLE: class-wrapper < alien-wrapper disposed ;
MIXIN: c++-root
GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
@ -27,6 +31,8 @@ M: struct-wrapper unmarshall-cast ;
M: struct-wrapper dispose* underlying>> free ;
M: class-wrapper c++-type class name>> parse-c++-type ;
: marshall-pointer ( obj -- alien )
{
{ [ dup alien? ] [ ] }
@ -269,33 +275,43 @@ ALIAS: marshall-void* marshall-pointer
: ?malloc-byte-array ( c-type -- alien )
dup alien? [ malloc-byte-array ] unless ;
: struct-unmarshaller ( type -- quot )
current-vocab lookup [
dup superclasses [ \ struct-wrapper = ] any? [
'[ ?malloc-byte-array _ new swap >>underlying ]
] [ drop [ ] ] if
] [ [ ] ] if* ;
:: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
type type-quot call current-vocab lookup [
dup superclasses superclass swap member?
[ def call ] [ drop clean call f ] if
] [ clean call f ] if* ; inline
: pointer-unmarshaller ( type -- quot )
type-sans-pointer current-vocab lookup [
dup superclasses [ \ alien-wrapper = ] any? [
'[ _ new swap >>underlying unmarshall-cast ]
] [ drop [ ] ] if
] [ [ ] ] if* ;
: struct-unmarshaller ( type -- quot/f )
[ ] \ struct-wrapper
[ '[ ?malloc-byte-array _ new swap >>underlying ] ]
[ ]
x-unmarshaller ;
: class-unmarshaller ( type -- quot/f )
[ type-sans-pointer "#" append ] \ class-wrapper
[ '[ _ new swap >>underlying ] ]
[ ]
x-unmarshaller ;
: non-primitive-unmarshaller ( type -- quot/f )
{
{ [ dup pointer? ] [ class-unmarshaller ] }
[ struct-unmarshaller ]
} cond ;
: unmarshaller ( type -- quot )
factorize-type dup primitive-unmarshaller [ nip ] [
dup pointer?
[ pointer-unmarshaller ]
[ struct-unmarshaller ] if
] if* ;
factorize-type {
[ primitive-unmarshaller ]
[ non-primitive-unmarshaller ]
[ drop [ ] ]
} 1|| ;
: struct-field-unmarshaller ( type -- quot )
factorize-type dup struct-primitive-unmarshaller [ nip ] [
dup pointer?
[ pointer-unmarshaller ]
[ struct-unmarshaller ] if
] if* ;
factorize-type {
[ struct-primitive-unmarshaller ]
[ non-primitive-unmarshaller ]
[ drop [ ] ]
} 1|| ;
: out-arg-unmarshaller ( type -- quot )
dup pointer-to-non-const-primitive?

43
extra/combinators/tuple/tuple-docs.factor Normal file
View File

@ -0,0 +1,43 @@
! (c)2009 Joe Groff bsd license
USING: assocs classes help.markup help.syntax kernel math
quotations strings ;
IN: combinators.tuple
HELP: 2make-tuple
{ $values
{ "x" object } { "y" object } { "class" class } { "assoc" assoc }
{ "tuple" tuple }
}
{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } " and " { $snippet "y" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
HELP: 3make-tuple
{ $values
{ "x" object } { "y" object } { "z" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" }
{ "tuple" tuple }
}
{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", " { $snippet "y" } ", and " { $snippet "z" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y z -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
HELP: make-tuple
{ $values
{ "x" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" }
{ "tuple" tuple }
}
{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
HELP: nmake-tuple
{ $values
{ "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" } { "n" integer }
}
{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on the top " { $snippet "n" } " values on the datastack below " { $snippet "class" } ", assigning the result of each call to the slot named by the corresponding key. The order in which the quotations is called is undefined." } ;
{ make-tuple 2make-tuple 3make-tuple nmake-tuple } related-words
ARTICLE: "combinators.tuple" "Tuple-constructing combinators"
"The " { $vocab-link "combinators.tuple" } " vocabulary provides dataflow combinators that construct " { $link tuple } " objects."
{ $subsection make-tuple }
{ $subsection 2make-tuple }
{ $subsection 3make-tuple }
{ $subsection nmake-tuple }
;
ABOUT: "combinators.tuple"

29
extra/combinators/tuple/tuple.factor Normal file
View File

@ -0,0 +1,29 @@
! (c)2009 Joe Groff bsd license
USING: accessors assocs classes.tuple generalizations kernel
locals quotations sequences ;
IN: combinators.tuple
<PRIVATE
:: (tuple-slot-quot) ( slot assoc n -- quot )
slot name>> assoc at [
slot initial>> :> initial
{ n ndrop initial } >quotation
] unless* ;
PRIVATE>
MACRO:: nmake-tuple ( class assoc n -- )
class all-slots [ assoc n (tuple-slot-quot) ] map :> quots
class <wrapper> :> \class
{ quots n ncleave \class boa } >quotation ;
: make-tuple ( x class assoc -- tuple )
1 nmake-tuple ; inline
: 2make-tuple ( x y class assoc -- tuple )
2 nmake-tuple ; inline
: 3make-tuple ( x y z class assoc -- tuple )
3 nmake-tuple ; inline

47
extra/constructors/constructors-tests.factor
View File

@ -29,58 +29,15 @@ CONSTRUCTOR: ct1 ( a -- obj )
[ 1 + ] change-a ;
CONSTRUCTOR: ct2 ( a b -- obj )
initialize-ct1
[ 1 + ] change-a ;
CONSTRUCTOR: ct3 ( a b c -- obj )
initialize-ct1
[ 1 + ] change-a ;
CONSTRUCTOR: ct4 ( a b c d -- obj )
initialize-ct3
[ 1 + ] change-a ;
[ 1001 ] [ 1000 <ct1> a>> ] unit-test
[ 2 ] [ 0 0 <ct2> a>> ] unit-test
[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test
TUPLE: rofl a b c ;
CONSTRUCTOR: rofl ( b c a -- obj ) ;
[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 <rofl> ] unit-test
TUPLE: default { a integer initial: 0 } ;
CONSTRUCTOR: default ( -- obj ) ;
[ 0 ] [ <default> a>> ] unit-test
TUPLE: inherit1 a ;
TUPLE: inherit2 < inherit1 a ;
CONSTRUCTOR: inherit2 ( a -- obj ) ;
[ T{ inherit2 f f 100 } ] [ 100 <inherit2> ] unit-test
TUPLE: inherit3 hp max-hp ;
TUPLE: inherit4 < inherit3 ;
TUPLE: inherit5 < inherit3 ;
CONSTRUCTOR: inherit3 ( -- obj )
dup max-hp>> >>hp ;
BACKWARD-CONSTRUCTOR: inherit4 ( -- obj )
10 >>max-hp ;
[ 10 ] [ <inherit4> hp>> ] unit-test
FORWARD-CONSTRUCTOR: inherit5 ( -- obj )
5 >>hp
10 >>max-hp ;
[ 5 ] [ <inherit5> hp>> ] unit-test
[ 3 ] [ 0 0 0 <ct3> a>> ] unit-test
[ 4 ] [ 0 0 0 0 <ct4> a>> ] unit-test

12
extra/constructors/constructors.factor
View File

@ -43,12 +43,7 @@ MACRO:: slots>constructor ( class slots -- quot )
class def define-initializer
class effect in>> '[ _ _ slots>constructor ] ;
:: define-constructor ( constructor-word class effect def -- )
constructor-word class effect def (define-constructor)
class lookup-initializer
'[ @ _ execute( obj -- obj ) ] effect define-declared ;
:: define-auto-constructor ( constructor-word class effect def reverse? -- )
:: define-constructor ( constructor-word class effect def reverse? -- )
constructor-word class effect def (define-constructor)
class superclasses [ lookup-initializer ] map sift
reverse? [ reverse ] when
@ -60,9 +55,6 @@ MACRO:: slots>constructor ( class slots -- quot )
: parse-constructor ( -- class word effect def )
scan-constructor complete-effect parse-definition ;
SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ;
SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ;
SYNTAX: AUTO-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ;
"initializers" create-vocab drop

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