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

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

Joe Groff 2009-07-01 13:55:24 -05:00
parent 823616ddc6 720ad7cfa7
commit 786d18e66c
53 changed files with 1235 additions and 624 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
basis/checksums/sha/sha.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel splitting grouping math sequences namespaces make
io.binary math.bitwise checksums checksums.common
sbufs strings combinators.smart math.ranges fry combinators
accessors locals checksums.stream multiline literals
generalizations ;
USING: accessors checksums checksums.common checksums.stream
combinators combinators.smart fry generalizations grouping
io.binary kernel literals locals make math math.bitwise
math.ranges multiline namespaces sbufs sequences
sequences.private splitting strings ;
IN: checksums.sha
SINGLETON: sha1
@ -230,21 +230,21 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
: prepare-M-256 ( n seq -- )
{
[ [ 16 - ] dip nth ]
[ [ 15 - ] dip nth s0-256 ]
[ [ 7 - ] dip nth ]
[ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
[ [ 16 - ] dip nth-unsafe ]
[ [ 15 - ] dip nth-unsafe s0-256 ]
[ [ 7 - ] dip nth-unsafe ]
[ [ 2 - ] dip nth-unsafe s1-256 w+ w+ w+ ]
[ ]
} 2cleave set-nth ; inline
} 2cleave set-nth-unsafe ; inline
: prepare-M-512 ( n seq -- )
{
[ [ 16 - ] dip nth ]
[ [ 15 - ] dip nth s0-512 ]
[ [ 7 - ] dip nth ]
[ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
[ [ 16 - ] dip nth-unsafe ]
[ [ 15 - ] dip nth-unsafe s0-512 ]
[ [ 7 - ] dip nth-unsafe ]
[ [ 2 - ] dip nth-unsafe s1-512 w+ w+ w+ ]
[ ]
} 2cleave set-nth ; inline
} 2cleave set-nth-unsafe ; inline
: ch ( x y z -- x' )
[ bitxor bitand ] keep bitxor ; inline
@ -258,36 +258,36 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
:: T1-256 ( n M H sha2 -- T1 )
n M nth
n sha2 K>> nth +
n M nth-unsafe
n sha2 K>> nth-unsafe +
e H slice3 ch w+
e H nth S1-256 w+
h H nth w+ ; inline
e H nth-unsafe S1-256 w+
h H nth-unsafe w+ ; inline
: T2-256 ( H -- T2 )
[ a swap nth S0-256 ]
[ a swap nth-unsafe S0-256 ]
[ a swap slice3 maj w+ ] bi ; inline
:: T1-512 ( n M H sha2 -- T1 )
n M nth
n sha2 K>> nth +
n M nth-unsafe
n sha2 K>> nth-unsafe +
e H slice3 ch w+
e H nth S1-512 w+
h H nth w+ ; inline
e H nth-unsafe S1-512 w+
h H nth-unsafe w+ ; inline
: T2-512 ( H -- T2 )
[ a swap nth S0-512 ]
[ a swap nth-unsafe S0-512 ]
[ a swap slice3 maj w+ ] bi ; inline
: update-H ( T1 T2 H -- )
h g pick exchange
g f pick exchange
f e pick exchange
pick d pick nth w+ e pick set-nth
d c pick exchange
c b pick exchange
b a pick exchange
[ w+ a ] dip set-nth ; inline
h g pick exchange-unsafe
g f pick exchange-unsafe
f e pick exchange-unsafe
pick d pick nth-unsafe w+ e pick set-nth-unsafe
d c pick exchange-unsafe
c b pick exchange-unsafe
b a pick exchange-unsafe
[ w+ a ] dip set-nth-unsafe ; inline
: prepare-message-schedule ( seq sha2 -- w-seq )
[ word-size>> <sliced-groups> [ be> ] map ]
@ -309,7 +309,7 @@ M: sha2-short checksum-block
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
: seq>byte-array ( seq n -- string )
'[ _ >be ] map B{ } join ;
'[ _ >be ] map B{ } concat-as ;
: sha1>checksum ( sha2 -- bytes )
H>> 4 seq>byte-array ;
@ -342,16 +342,14 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
drop
[ <sha-256-state> ] dip add-checksum-stream get-checksum ;
: sha1-W ( t seq -- )
{
[ [ 3 - ] dip nth ]
[ [ 8 - ] dip nth bitxor ]
[ [ 14 - ] dip nth bitxor ]
[ [ 16 - ] dip nth bitxor 1 bitroll-32 ]
[ [ 3 - ] dip nth-unsafe ]
[ [ 8 - ] dip nth-unsafe bitxor ]
[ [ 14 - ] dip nth-unsafe bitxor ]
[ [ 16 - ] dip nth-unsafe bitxor 1 bitroll-32 ]
[ ]
} 2cleave set-nth ;
} 2cleave set-nth-unsafe ;
: prepare-sha1-message-schedule ( seq -- w-seq )
4 <sliced-groups> [ be> ] map
@ -368,11 +366,11 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
} case ;
:: inner-loop ( n H W K -- temp )
a H nth :> A
b H nth :> B
c H nth :> C
d H nth :> D
e H nth :> E
a H nth-unsafe :> A
b H nth-unsafe :> B
c H nth-unsafe :> C
d H nth-unsafe :> D
e H nth-unsafe :> E
[
A 5 bitroll-32
@ -380,19 +378,19 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
E
n K nth
n K nth-unsafe
n W nth
n W nth-unsafe
] sum-outputs 32 bits ;
:: process-sha1-chunk ( bytes H W K state -- )
80 [
H W K inner-loop
d H nth e H set-nth
c H nth d H set-nth
b H nth 30 bitroll-32 c H set-nth
a H nth b H set-nth
a H set-nth
d H nth-unsafe e H set-nth-unsafe
c H nth-unsafe d H set-nth-unsafe
b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
a H nth-unsafe b H set-nth-unsafe
a H set-nth-unsafe
] each
state [ H [ w+ ] 2map ] change-H drop ; inline

30
basis/compiler/cfg/branch-folding/branch-folding.factor Normal file
View File

@ -0,0 +1,30 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit kernel sequences vectors
compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.branch-folding
! Fold comparisons where both inputs are the same. Predecessors must be
! recomputed after this
: fold-branch? ( bb -- ? )
instructions>> last {
[ ##compare-branch? ]
[ [ src1>> ] [ src2>> ] bi = ]
} 1&& ;
: chosen-successor ( bb -- succ )
[ instructions>> last cc>> { cc= cc<= cc>= } memq? 0 1 ? ]
[ successors>> ]
bi nth ;
: fold-branch ( bb -- )
dup chosen-successor 1vector >>successors
instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ;
: fold-branches ( cfg -- cfg' )
dup [
dup fold-branch?
[ fold-branch ] [ drop ] if
] each-basic-block
f >>post-order ;

1
basis/compiler/cfg/branch-splitting/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

37
basis/compiler/cfg/branch-splitting/branch-splitting.factor Normal file
View File

@ -0,0 +1,37 @@
! Copyright (C) 2009 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit kernel math sequences
compiler.cfg.def-use compiler.cfg compiler.cfg.rpo ;
IN: compiler.cfg.branch-splitting
! Predecessors must be recomputed after this
: split-branch-for ( bb predecessor -- )
[
[
<basic-block>
swap
[ instructions>> [ clone ] map >>instructions ]
[ successors>> clone >>successors ]
bi
] keep
] dip
[ [ 2dup eq? [ 2drop ] [ 2nip ] if ] with with map ] change-successors
drop ;
: split-branch ( bb -- )
dup predecessors>> [ split-branch-for ] with each ;
: split-branches? ( bb -- ? )
{
[ successors>> empty? ]
[ predecessors>> length 1 > ]
[ instructions>> [ defs-vregs ] any? not ]
[ instructions>> [ temp-vregs ] any? not ]
} 1&& ;
: split-branches ( cfg -- cfg' )
dup [
dup split-branches? [ split-branch ] [ drop ] if
] each-basic-block
f >>post-order ;

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

@ -18,10 +18,14 @@ kernel.private math ;
[ 3 fixnum+fast ]
[ fixnum*fast ]
[ 3 fixnum*fast ]
[ 3 swap fixnum*fast ]
[ fixnum-shift-fast ]
[ 10 fixnum-shift-fast ]
[ -10 fixnum-shift-fast ]
[ 0 fixnum-shift-fast ]
[ 10 swap fixnum-shift-fast ]
[ -10 swap fixnum-shift-fast ]
[ 0 swap fixnum-shift-fast ]
[ fixnum-bitnot ]
[ eq? ]
[ "hi" eq? ]

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

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words byte-arrays
@ -11,7 +11,6 @@ compiler.tree.propagation.info
compiler.cfg
compiler.cfg.hats
compiler.cfg.stacks
compiler.cfg.iterator
compiler.cfg.utilities
compiler.cfg.registers
compiler.cfg.intrinsics
@ -26,10 +25,6 @@ SYMBOL: procedures
SYMBOL: current-word
SYMBOL: current-label
SYMBOL: loops
SYMBOL: first-basic-block
! Basic block after prologue, makes recursion faster
SYMBOL: current-label-start
: add-procedure ( -- )
basic-block get current-word get current-label get
@ -46,27 +41,22 @@ SYMBOL: current-label-start
: with-cfg-builder ( nodes word label quot -- )
'[ begin-procedure @ ] with-scope ; inline
GENERIC: emit-node ( node -- next )
GENERIC: emit-node ( node -- )
: check-basic-block ( node -- node' )
basic-block get [ drop f ] unless ; inline
: emit-nodes ( nodes -- )
[ current-node emit-node check-basic-block ] iterate-nodes ;
[ basic-block get [ emit-node ] [ drop ] if ] each ;
: begin-word ( -- )
#! We store the basic block after the prologue as a loop
#! labeled by the current word, so that self-recursive
#! calls can skip an epilogue/prologue.
##prologue
##branch
begin-basic-block
basic-block get first-basic-block set ;
begin-basic-block ;
: (build-cfg) ( nodes word label -- )
[
begin-word
V{ } clone node-stack set
emit-nodes
] with-cfg-builder ;
@ -77,37 +67,30 @@ GENERIC: emit-node ( node -- next )
] with-variable
] keep ;
: local-recursive-call ( basic-block -- next )
: emit-loop-call ( basic-block -- )
##branch
basic-block get successors>> push
stop-iterating ;
basic-block off ;
: emit-call ( word height -- next )
{
{ [ over loops get key? ] [ drop loops get at local-recursive-call ] }
{ [ terminate-call? ] [ ##call stop-iterating ] }
{ [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
{ [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] }
[ drop ##epilogue ##jump stop-iterating ]
} cond ;
: emit-call ( word -- )
dup loops get key?
[ loops get at emit-loop-call ]
[ ##call ##branch begin-basic-block ]
if ;
! #recursive
: recursive-height ( #recursive -- n )
[ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
: emit-recursive ( #recursive -- next )
[ [ label>> id>> ] [ recursive-height ] bi emit-call ]
: emit-recursive ( #recursive -- )
[ label>> id>> emit-call ]
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
: remember-loop ( label -- )
basic-block get swap loops get set-at ;
: emit-loop ( node -- next )
: emit-loop ( node -- )
##loop-entry
##branch
begin-basic-block
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
iterate-next ;
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
M: #recursive emit-node
dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
@ -121,7 +104,7 @@ M: #recursive emit-node
] with-scope ;
: emit-if ( node -- )
children>> [ emit-branch ] map
children>> [ emit-branch ] map
end-basic-block
begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each ;
@ -157,23 +140,23 @@ 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 ]
} cond iterate-next ;
} cond ;
! #dispatch
M: #dispatch emit-node
ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
ds-pop ^^offset>slot i ##dispatch emit-if ;
! #call
M: #call emit-node
dup word>> dup "intrinsic" word-prop
[ emit-intrinsic ] [ swap call-height emit-call ] if ;
[ emit-intrinsic ] [ nip emit-call ] if ;
! #call-recursive
M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
M: #call-recursive emit-node label>> id>> emit-call ;
! #push
M: #push emit-node
literal>> ^^load-literal ds-push iterate-next ;
literal>> ^^load-literal ds-push ;
! #shuffle
M: #shuffle emit-node
@ -183,19 +166,18 @@ M: #shuffle emit-node
[ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
[ nip ] 2tri
[ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
[ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi
iterate-next ;
[ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
! #return
M: #return emit-node
drop ##epilogue ##return stop-iterating ;
drop ##epilogue ##return ;
M: #return-recursive emit-node
label>> id>> loops get key?
[ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
[ ##epilogue ##return ] unless ;
! #terminate
M: #terminate emit-node drop stop-iterating ;
M: #terminate emit-node drop ##no-tco basic-block off ;
! FFI
: return-size ( ctype -- n )
@ -215,9 +197,9 @@ M: #terminate emit-node drop stop-iterating ;
: alien-stack-frame ( params -- )
<alien-stack-frame> ##stack-frame ;
: emit-alien-node ( node quot -- next )
: emit-alien-node ( node quot -- )
[ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
##branch begin-basic-block iterate-next ; inline
##branch begin-basic-block ; inline
M: #alien-invoke emit-node
[ ##alien-invoke ] emit-alien-node ;
@ -229,17 +211,16 @@ M: #alien-callback emit-node
dup params>> xt>> dup
[
##prologue
dup [ ##alien-callback ] emit-alien-node drop
dup [ ##alien-callback ] emit-alien-node
##epilogue
params>> ##callback-return
] with-cfg-builder
iterate-next ;
] with-cfg-builder ;
! No-op nodes
M: #introduce emit-node drop iterate-next ;
M: #introduce emit-node drop ;
M: #copy emit-node drop iterate-next ;
M: #copy emit-node drop ;
M: #enter-recursive emit-node drop iterate-next ;
M: #enter-recursive emit-node drop ;
M: #phi emit-node drop iterate-next ;
M: #phi emit-node drop ;

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

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

@ -1,7 +1,9 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays vectors accessors
namespaces math make fry sequences ;
USING: kernel arrays vectors accessors assocs sets
namespaces math make fry sequences
combinators.short-circuit
compiler.cfg.instructions ;
IN: compiler.cfg
TUPLE: basic-block < identity-tuple
@ -20,6 +22,25 @@ M: basic-block hashcode* nip id>> ;
V{ } clone >>predecessors
\ basic-block counter >>id ;
: empty-block? ( bb -- ? )
instructions>> {
[ length 1 = ]
[ first ##branch? ]
} 1&& ;
SYMBOL: visited
: (skip-empty-blocks) ( bb -- bb' )
dup visited get key? [
dup empty-block? [
dup visited get conjoin
successors>> first (skip-empty-blocks)
] when
] unless ;
: skip-empty-blocks ( bb -- bb' )
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
: add-instructions ( bb quot -- )
[ instructions>> building ] dip '[
building get pop

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

@ -19,7 +19,7 @@ ERROR: last-insn-not-a-jump insn ;
[ ##fixnum-add-tail? ]
[ ##fixnum-sub-tail? ]
[ ##fixnum-mul-tail? ]
[ ##call? ]
[ ##no-tco? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
ERROR: bad-loop-entry ;

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

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io
USING: kernel words sequences quotations namespaces io vectors
classes.tuple accessors prettyprint prettyprint.config
prettyprint.backend prettyprint.custom prettyprint.sections
parser compiler.tree.builder compiler.tree.optimizer
@ -8,7 +8,7 @@ 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.mr ;
compiler.cfg.mr compiler.cfg ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
@ -49,3 +49,12 @@ M: vreg pprint*
M: ds-loc pprint* \ D pprint-loc ;
M: rs-loc pprint* \ R pprint-loc ;
: test-bb ( insns n -- )
[ <basic-block> swap >>number swap >>instructions ] keep set ;
: test-diamond ( -- )
1 get 1vector 0 get (>>successors)
2 get 3 get V{ } 2sequence 1 get (>>successors)
4 get 1vector 2 get (>>successors)
4 get 1vector 3 get (>>successors) ;

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

@ -1,55 +0,0 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math namespaces sequences kernel fry
compiler.cfg compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.liveness compiler.cfg.local ;
IN: compiler.cfg.height
! Combine multiple stack height changes into one at the
! start of the basic block.
SYMBOL: ds-height
SYMBOL: rs-height
GENERIC: compute-heights ( insn -- )
M: ##inc-d compute-heights n>> ds-height [ + ] change ;
M: ##inc-r compute-heights n>> rs-height [ + ] change ;
M: insn compute-heights drop ;
GENERIC: normalize-height* ( insn -- insn' )
: normalize-inc-d/r ( insn stack -- insn' )
swap n>> '[ _ - ] change f ; inline
M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
GENERIC: loc-stack ( loc -- stack )
M: ds-loc loc-stack drop ds-height ;
M: rs-loc loc-stack drop rs-height ;
GENERIC: <loc> ( n stack -- loc )
M: ds-loc <loc> drop <ds-loc> ;
M: rs-loc <loc> drop <rs-loc> ;
: normalize-peek/replace ( insn -- insn' )
[ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
M: ##peek normalize-height* normalize-peek/replace ;
M: ##replace normalize-height* normalize-peek/replace ;
M: insn normalize-height* ;
: height-step ( insns -- insns' )
0 ds-height set
0 rs-height set
[ [ compute-heights ] each ]
[ [ [ normalize-height* ] map sift ] with-scope ] bi
ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
: normalize-height ( cfg -- cfg' )
[ drop ] [ height-step ] local-optimization ;

1
basis/compiler/cfg/height/summary.txt
View File

@ -1 +0,0 @@
Stack height normalization coalesces height changes at start of basic block

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

@ -53,10 +53,13 @@ INSN: ##inc-r { n integer } ;
! Subroutine calls
INSN: ##stack-frame stack-frame ;
INSN: ##call word { height integer } ;
INSN: ##call word ;
INSN: ##jump word ;
INSN: ##return ;
! Dummy instruction that simply inhibits TCO
INSN: ##no-tco ;
! Jump tables
INSN: ##dispatch src temp ;
@ -247,3 +250,5 @@ INSN: _spill src class n ;
INSN: _reload dst class n ;
INSN: _copy dst src class ;
INSN: _spill-counts counts ;
SYMBOL: spill-temp

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

@ -1,11 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors layouts kernel math namespaces
combinators fry locals
compiler.tree.propagation.info
compiler.cfg.hats
compiler.cfg.stacks
compiler.cfg.iterator
compiler.cfg.instructions
compiler.cfg.utilities
compiler.cfg.registers ;
@ -18,13 +17,14 @@ IN: compiler.cfg.intrinsics.fixnum
0 cc= ^^compare-imm
ds-push ;
: (emit-fixnum-imm-op) ( infos insn -- dst )
ds-drop
[ ds-pop ]
[ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
[ ]
tri*
call ; inline
: tag-literal ( n -- tagged )
literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
: emit-fixnum-imm-op1 ( infos insn -- dst )
[ ds-pop ds-drop ] [ first tag-literal ] [ ] tri* call ; inline
: emit-fixnum-imm-op2 ( infos insn -- dst )
[ ds-drop ds-pop ] [ second tag-literal ] [ ] tri* call ; inline
: (emit-fixnum-op) ( insn -- dst )
[ 2inputs ] dip call ; inline
@ -32,24 +32,46 @@ IN: compiler.cfg.intrinsics.fixnum
:: emit-fixnum-op ( node insn imm-insn -- )
[let | infos [ node node-input-infos ] |
infos second value-info-small-tagged?
[ infos imm-insn (emit-fixnum-imm-op) ]
[ insn (emit-fixnum-op) ]
if
[ infos imm-insn emit-fixnum-imm-op2 ]
[ insn (emit-fixnum-op) ] if
ds-push
] ; inline
: emit-fixnum-shift-fast ( node -- )
dup node-input-infos dup second value-info-small-fixnum? [
nip
[ ds-drop ds-pop ] dip
second literal>> dup sgn {
{ -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
{ 0 [ drop ] }
{ 1 [ ^^shl-imm ] }
} case
:: emit-commutative-fixnum-op ( node insn imm-insn -- )
[let | infos [ node node-input-infos ] |
infos first value-info-small-tagged?
[ infos imm-insn emit-fixnum-imm-op1 ]
[
infos second value-info-small-tagged? [
infos imm-insn emit-fixnum-imm-op2
] [
insn (emit-fixnum-op)
] if
] if
ds-push
] [ drop emit-primitive ] if ;
] ; inline
: (emit-fixnum-shift-fast) ( obj node -- obj )
literal>> dup sgn {
{ -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
{ 0 [ drop ] }
{ 1 [ ^^shl-imm ] }
} case ;
: emit-fixnum-shift-fast ( node -- )
dup node-input-infos dup first value-info-small-fixnum? [
nip
[ ds-pop ds-drop ] dip first (emit-fixnum-shift-fast) ds-push
] [
drop
dup node-input-infos dup second value-info-small-fixnum? [
nip
[ ds-drop ds-pop ] dip second (emit-fixnum-shift-fast) ds-push
] [
drop emit-primitive
] if
] if ;
: emit-fixnum-bitnot ( -- )
ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
@ -59,19 +81,31 @@ IN: compiler.cfg.intrinsics.fixnum
: (emit-fixnum*fast) ( -- dst )
2inputs ^^untag-fixnum ^^mul ;
: (emit-fixnum*fast-imm) ( infos -- dst )
ds-drop
[ ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
: (emit-fixnum*fast-imm1) ( infos -- dst )
[ ds-pop ds-drop ] [ first literal>> ] bi* ^^mul-imm ;
: (emit-fixnum*fast-imm2) ( infos -- dst )
[ ds-drop ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
: emit-fixnum*fast ( node -- )
node-input-infos
dup second value-info-small-fixnum?
[ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
dup first value-info-small-fixnum?
[
(emit-fixnum*fast-imm1)
] [
dup second value-info-small-fixnum?
[ (emit-fixnum*fast-imm2) ] [ drop (emit-fixnum*fast) ] if
] if
ds-push ;
: (emit-fixnum-comparison) ( cc -- quot1 quot2 )
[ ^^compare ] [ ^^compare-imm ] bi-curry ; inline
: emit-eq ( node -- )
cc= (emit-fixnum-comparison) emit-commutative-fixnum-op ;
: emit-fixnum-comparison ( node cc -- )
[ ^^compare ] [ ^^compare-imm ] bi-curry
emit-fixnum-op ;
(emit-fixnum-comparison) emit-fixnum-op ;
: emit-bignum>fixnum ( -- )
ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
@ -79,15 +113,6 @@ IN: compiler.cfg.intrinsics.fixnum
: emit-fixnum>bignum ( -- )
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
: emit-fixnum-overflow-op ( quot quot-tail -- next )
[ 2inputs 1 ##inc-d ] 2dip
tail-call? [
##epilogue
nip call
stop-iterating
] [
drop call
##branch
begin-basic-block
iterate-next
] if ; inline
: emit-fixnum-overflow-op ( quot -- next )
[ 2inputs 1 ##inc-d ] dip call ##branch
begin-basic-block ; inline

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

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel combinators cpu.architecture
compiler.cfg.hats
@ -8,8 +8,7 @@ compiler.cfg.intrinsics.allot
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.slots
compiler.cfg.intrinsics.misc
compiler.cfg.iterator ;
compiler.cfg.intrinsics.misc ;
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: byte-arrays
@ -95,66 +94,66 @@ IN: compiler.cfg.intrinsics
: enable-fixnum-log2 ( -- )
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
: emit-intrinsic ( node word -- node/f )
: emit-intrinsic ( node word -- )
{
{ \ kernel.private:tag [ drop emit-tag iterate-next ] }
{ \ kernel.private:getenv [ emit-getenv iterate-next ] }
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
{ \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
{ \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] }
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] }
{ \ kernel:eq? [ cc= emit-fixnum-comparison iterate-next ] }
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] }
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] }
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] }
{ \ math.private:float- [ drop [ ^^sub-float ] emit-float-op iterate-next ] }
{ \ math.private:float* [ drop [ ^^mul-float ] emit-float-op iterate-next ] }
{ \ math.private:float/f [ drop [ ^^div-float ] emit-float-op iterate-next ] }
{ \ math.private:float< [ drop cc< emit-float-comparison iterate-next ] }
{ \ math.private:float<= [ drop cc<= emit-float-comparison iterate-next ] }
{ \ math.private:float>= [ drop cc>= emit-float-comparison iterate-next ] }
{ \ math.private:float> [ drop cc> emit-float-comparison iterate-next ] }
{ \ math.private:float= [ drop cc= emit-float-comparison iterate-next ] }
{ \ math.private:float>fixnum [ drop emit-float>fixnum iterate-next ] }
{ \ math.private:fixnum>float [ drop emit-fixnum>float iterate-next ] }
{ \ slots.private:slot [ emit-slot iterate-next ] }
{ \ slots.private:set-slot [ emit-set-slot iterate-next ] }
{ \ strings.private:string-nth [ drop emit-string-nth iterate-next ] }
{ \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] }
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
{ \ arrays:<array> [ emit-<array> iterate-next ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
{ \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
{ \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter iterate-next ] }
{ \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter iterate-next ] }
{ \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter iterate-next ] }
{ \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter iterate-next ] }
{ \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter iterate-next ] }
{ \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter iterate-next ] }
{ \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter iterate-next ] }
{ \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter iterate-next ] }
{ \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter iterate-next ] }
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter iterate-next ] }
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter iterate-next ] }
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter iterate-next ] }
{ \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter iterate-next ] }
{ \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter iterate-next ] }
{ \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter iterate-next ] }
{ \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter iterate-next ] }
{ \ kernel.private:tag [ drop emit-tag ] }
{ \ kernel.private:getenv [ emit-getenv ] }
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-commutative-fixnum-op ] }
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op ] }
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op ] }
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op ] }
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
{ \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
{ \ math.private:fixnum*fast [ emit-fixnum*fast ] }
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
{ \ kernel:eq? [ emit-eq ] }
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
{ \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
{ \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
{ \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
{ \ math.private:float< [ drop cc< emit-float-comparison ] }
{ \ math.private:float<= [ drop cc<= emit-float-comparison ] }
{ \ math.private:float>= [ drop cc>= emit-float-comparison ] }
{ \ math.private:float> [ drop cc> emit-float-comparison ] }
{ \ math.private:float= [ drop cc= emit-float-comparison ] }
{ \ math.private:float>fixnum [ drop emit-float>fixnum ] }
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
{ \ slots.private:slot [ emit-slot ] }
{ \ slots.private:set-slot [ emit-set-slot ] }
{ \ strings.private:string-nth [ drop emit-string-nth ] }
{ \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
{ \ arrays:<array> [ emit-<array> ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
{ \ byte-arrays:(byte-array) [ emit-(byte-array) ] }
{ \ kernel:<wrapper> [ emit-simple-allot ] }
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
{ \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
{ \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
} case ;

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

@ -1,45 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences kernel compiler.tree ;
IN: compiler.cfg.iterator
SYMBOL: node-stack
: >node ( cursor -- ) node-stack get push ;
: node> ( -- cursor ) node-stack get pop ;
: node@ ( -- cursor ) node-stack get last ;
: current-node ( -- node ) node@ first ;
: iterate-next ( -- cursor ) node@ rest-slice ;
: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
: iterate-nodes ( cursor quot: ( -- ) -- )
over empty? [
2drop
] [
[ swap >node call node> drop ] keep iterate-nodes
] if ; inline recursive
DEFER: (tail-call?)
: tail-phi? ( cursor -- ? )
[ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
: (tail-call?) ( cursor -- ? )
[ t ] [
[
first
[ #return? ]
[ #return-recursive? ]
[ #terminate? ] tri or or
] [ tail-phi? ] bi or
] if-empty ;
: tail-call? ( -- ? )
node-stack get [
rest-slice
[ t ] [ (tail-call?) ] if-empty
] all? ;
: terminate-call? ( -- ? )
node-stack get last
rest-slice [ f ] [ first #terminate? ] if-empty ;

1
basis/compiler/cfg/iterator/summary.txt
View File

@ -1 +0,0 @@
Utility for iterating for high-level IR

24
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs heaps kernel namespaces sequences fry math
combinators arrays sorting compiler.utilities
math.order combinators arrays sorting compiler.utilities
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation.coalescing
compiler.cfg.linear-scan.allocation.spilling
@ -12,17 +12,23 @@ IN: compiler.cfg.linear-scan.allocation
: free-positions ( new -- assoc )
vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
: active-positions ( new -- assoc )
vreg>> active-intervals-for [ reg>> 0 ] H{ } map>assoc ;
: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
: inactive-positions ( new -- assoc )
dup vreg>> inactive-intervals-for
[ [ reg>> swap ] keep relevant-ranges intersect-live-ranges ]
with H{ } map>assoc ;
: active-positions ( new assoc -- )
[ vreg>> active-intervals-for ] dip
'[ [ 0 ] dip reg>> _ add-use-position ] each ;
: inactive-positions ( new assoc -- )
[ [ vreg>> inactive-intervals-for ] keep ] dip
'[
[ _ relevant-ranges intersect-live-ranges ] [ reg>> ] bi
_ add-use-position
] each ;
: compute-free-pos ( new -- free-pos )
[ free-positions ] [ inactive-positions ] [ active-positions ] tri
3array assoc-combine >alist alist-max ;
dup free-positions
[ inactive-positions ] [ active-positions ] [ nip ] 2tri
>alist alist-max ;
: no-free-registers? ( result -- ? )
second 0 = ; inline

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

@ -50,9 +50,12 @@ ERROR: already-spilled ;
: handle-spill ( live-interval -- )
dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
: next-interval ( live-interval -- live-interval' )
split-next>> dup split-before>> [ next-interval ] [ ] ?if ;
: insert-copy ( live-interval -- )
{
[ split-next>> reg>> ]
[ next-interval reg>> ]
[ reg>> ]
[ vreg>> reg-class>> ]
[ end>> ]
@ -104,8 +107,19 @@ GENERIC: assign-registers-in-insn ( insn -- )
: all-vregs ( insn -- vregs )
[ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
SYMBOL: check-assignment?
ERROR: overlapping-registers intervals ;
: check-assignment ( intervals -- )
dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter
dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ;
: active-intervals ( insn -- intervals )
insn#>> pending-intervals get [ covers? ] with filter ;
insn#>> pending-intervals get [ covers? ] with filter
check-assignment? get [
dup check-assignment
] when ;
M: vreg-insn assign-registers-in-insn
dup [ active-intervals ] [ all-vregs ] bi

3
basis/compiler/cfg/linear-scan/debugger/debugger.factor
View File

@ -34,6 +34,3 @@ IN: compiler.cfg.linear-scan.debugger
: live-intervals. ( seq -- )
[ interval-picture ] map simple-table. ;
: test-bb ( insns n -- )
[ <basic-block> swap >>number swap >>instructions ] keep set ;

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

@ -18,10 +18,12 @@ compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.debugger ;
FROM: compiler.cfg.linear-scan.assignment => check-assignment? ;
check-allocation? on
check-assignment? on
[
{ T{ live-range f 1 10 } T{ live-range f 15 15 } }
@ -1417,6 +1419,58 @@ USING: math.private ;
relevant-ranges intersect-live-ranges
] unit-test
! compute-free-pos had problems because it used map>assoc where the sequence
! had multiple keys
[ { 0 10 } ] [
H{ { int-regs { 0 1 } } } registers set
H{
{ int-regs
{
T{ live-interval
{ vreg V int-regs 1 }
{ start 0 }
{ end 20 }
{ reg 0 }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
{ uses V{ 0 2 10 20 } }
}
T{ live-interval
{ vreg V int-regs 2 }
{ start 4 }
{ end 40 }
{ reg 0 }
{ ranges V{ T{ live-range f 4 6 } T{ live-range f 30 40 } } }
{ uses V{ 4 6 30 40 } }
}
}
}
} inactive-intervals set
H{
{ int-regs
{
T{ live-interval
{ vreg V int-regs 3 }
{ start 0 }
{ end 40 }
{ reg 1 }
{ ranges V{ T{ live-range f 0 40 } } }
{ uses V{ 0 40 } }
}
}
}
} active-intervals set
T{ live-interval
{ vreg V int-regs 4 }
{ start 8 }
{ end 10 }
{ ranges V{ T{ live-range f 8 10 } } }
{ uses V{ 8 10 } }
}
compute-free-pos
] unit-test
! Bug in live spill slots calculation
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
@ -1563,12 +1617,6 @@ V{
T{ ##return }
} 4 test-bb
: test-diamond ( -- )
1 get 1vector 0 get (>>successors)
2 get 3 get V{ } 2sequence 1 get (>>successors)
4 get 1vector 2 get (>>successors)
4 get 1vector 3 get (>>successors) ;
test-diamond
{ 1 2 3 4 } test-linear-scan-on-cfg

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

@ -1,4 +1,5 @@
USING: accessors arrays compiler.cfg compiler.cfg.instructions
USING: accessors arrays classes compiler.cfg
compiler.cfg.debugger compiler.cfg.instructions
compiler.cfg.linear-scan.debugger
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.numbering
@ -62,4 +63,137 @@ T{ live-interval
[ f ] [
1 get test-live-interval-2 reload-from
] unit-test
] unit-test
[
{
T{ _copy { dst 5 } { src 4 } { class int-regs } }
T{ _spill { src 1 } { class int-regs } { n spill-temp } }
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _reload { dst 0 } { class int-regs } { n spill-temp } }
T{ _spill { src 1 } { class float-regs } { n spill-temp } }
T{ _copy { dst 1 } { src 0 } { class float-regs } }
T{ _reload { dst 0 } { class float-regs } { n spill-temp } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _spill { src 2 } { class int-regs } { n spill-temp } }
T{ _copy { dst 2 } { src 1 } { class int-regs } }
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _reload { dst 0 } { class int-regs } { n spill-temp } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _spill { src 0 } { class int-regs } { n spill-temp } }
T{ _copy { dst 0 } { src 2 } { class int-regs } }
T{ _copy { dst 2 } { src 1 } { class int-regs } }
T{ _reload { dst 1 } { class int-regs } { n spill-temp } }
}
] [
{
T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _copy { dst 2 } { src 0 } { class int-regs } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{ }
] [
{
T{ register->register { from 4 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{ T{ _spill { src 4 } { class int-regs } { n spill-temp } } }
] [
{
T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _copy { dst 2 } { src 0 } { class int-regs } }
T{ _copy { dst 0 } { src 3 } { class int-regs } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _copy { dst 2 } { src 0 } { class int-regs } }
T{ _spill { src 4 } { class int-regs } { n spill-temp } }
T{ _copy { dst 4 } { src 0 } { class int-regs } }
T{ _copy { dst 0 } { src 3 } { class int-regs } }
T{ _reload { dst 3 } { class int-regs } { n spill-temp } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 2 } { src 0 } { class int-regs } }
T{ _copy { dst 9 } { src 1 } { class int-regs } }
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _spill { src 4 } { class int-regs } { n spill-temp } }
T{ _copy { dst 4 } { src 0 } { class int-regs } }
T{ _copy { dst 0 } { src 3 } { class int-regs } }
T{ _reload { dst 3 } { class int-regs } { n spill-temp } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
T{ register->register { from 1 } { to 9 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test

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

@ -1,9 +1,10 @@
! Copyright (C) 2009 Slava Pestov
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math namespaces sequences
classes.tuple classes.parser parser fry words make arrays
locals combinators compiler.cfg.linear-scan.live-intervals
compiler.cfg.liveness compiler.cfg.instructions ;
USING: accessors arrays assocs classes.parser classes.tuple
combinators combinators.short-circuit fry hashtables kernel locals
make math math.order namespaces sequences sets words parser
compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals
compiler.cfg.liveness ;
IN: compiler.cfg.linear-scan.resolve
<<
@ -67,27 +68,148 @@ M: memory->memory >insn
[ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
M: register->memory >insn
[ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
[ from>> ] [ reg-class>> ] bi spill-temp _spill ;
M: memory->register >insn
[ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
[ to>> ] [ reg-class>> ] bi spill-temp _reload ;
M: register->register >insn
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
GENERIC: >collision-table ( operation -- )
M: memory->memory >collision-table
[ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
M: register->memory >collision-table
[ from>> ] [ reg-class>> ] bi spill-temp _spill ;
M: memory->register >collision-table
[ to>> ] [ reg-class>> ] bi spill-temp _reload ;
M: register->register >collision-table
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
SYMBOL: froms
SYMBOL: tos
SINGLETONS: memory register ;
GENERIC: from-loc ( operation -- obj )
M: memory->memory from-loc drop memory ;
M: register->memory from-loc drop register ;
M: memory->register from-loc drop memory ;
M: register->register from-loc drop register ;
GENERIC: to-loc ( operation -- obj )
M: memory->memory to-loc drop memory ;
M: register->memory to-loc drop memory ;
M: memory->register to-loc drop register ;
M: register->register to-loc drop register ;
: from-reg ( operation -- seq )
[ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
: to-reg ( operation -- seq )
[ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
: start? ( operations -- pair )
from-reg tos get key? not ;
: independent-assignment? ( operations -- pair )
to-reg froms get key? not ;
: set-tos/froms ( operations -- )
[ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
[ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
bi ;
:: (trace-chain) ( obj hashtable -- )
obj to-reg froms get at* [
dup ,
obj over hashtable clone [ maybe-set-at ] keep swap
[ (trace-chain) ] [ 2drop ] if
] [
drop
] if ;
: trace-chain ( obj -- seq )
[
dup ,
dup dup associate (trace-chain)
] { } make prune reverse ;
: trace-chains ( seq -- seq' )
[ trace-chain ] map concat ;
ERROR: resolve-error ;
: split-cycle ( operations -- chain spilled-operation )
unclip [
[ set-tos/froms ]
[
[ start? ] find nip
[ resolve-error ] unless* trace-chain
] bi
] dip ;
: break-cycle-n ( operations -- operations' )
split-cycle [
[ from>> spill-temp ]
[ reg-class>> ] bi \ register->memory boa
] [
[ to>> spill-temp swap ]
[ reg-class>> ] bi \ memory->register boa
] bi [ 1array ] bi@ surround ;
: break-cycle ( operations -- operations' )
dup length {
{ 1 [ ] }
[ drop break-cycle-n ]
} case ;
: (group-cycles) ( seq -- )
[
dup set-tos/froms
unclip trace-chain
[ diff ] keep , (group-cycles)
] unless-empty ;
: group-cycles ( seq -- seqs )
[ (group-cycles) ] { } make ;
: remove-dead-mappings ( seq -- seq' )
prune [ [ from-reg ] [ to-reg ] bi = not ] filter ;
: parallel-mappings ( operations -- seq )
[
[ independent-assignment? not ] partition %
[ start? not ] partition
[ trace-chain ] map concat dup %
diff group-cycles [ break-cycle ] map concat %
] { } make remove-dead-mappings ;
: mapping-instructions ( mappings -- insns )
[ [ >insn ] each ] { } make ;
[
[ set-tos/froms ] [ parallel-mappings ] bi
[ [ >insn ] each ] { } make
] with-scope ;
: fork? ( from to -- ? )
[ successors>> length 1 >= ]
[ predecessors>> length 1 = ] bi* and ; inline
{
[ drop successors>> length 1 >= ]
[ nip predecessors>> length 1 = ]
} 2&& ; inline
: insert-position/fork ( from to -- before after )
nip instructions>> [ >array ] [ dup delete-all ] bi swap ;
: join? ( from to -- ? )
[ successors>> length 1 = ]
[ predecessors>> length 1 >= ] bi* and ; inline
{
[ drop successors>> length 1 = ]
[ nip predecessors>> length 1 >= ]
} 2&& ; inline
: insert-position/join ( from to -- before after )
drop instructions>> dup pop 1array ;
@ -115,4 +237,4 @@ M: register->register >insn
dup successors>> [ resolve-edge-data-flow ] with each ;
: resolve-data-flow ( rpo -- )
[ resolve-block-data-flow ] each ;
[ resolve-block-data-flow ] each ;

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

@ -24,19 +24,8 @@ M: insn linearize-insn , drop ;
#! don't need to branch.
[ number>> ] bi@ 1 - = ; inline
: branch-to-branch? ( successor -- ? )
#! A branch to a block containing just a jump return is cloned.
instructions>> dup length 2 = [
[ first ##epilogue? ]
[ second [ ##return? ] [ ##jump? ] bi or ] bi and
] [ drop f ] if ;
: emit-branch ( basic-block successor -- )
{
{ [ 2dup useless-branch? ] [ 2drop ] }
{ [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
[ nip number>> _branch ]
} cond ;
2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
M: ##branch linearize-insn
drop dup successors>> first emit-branch ;

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

@ -1,6 +1,7 @@
USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors
sequences.private math sbufs math.private slots.private strings ;
USING: arrays sequences tools.test compiler.cfg.checker
compiler.cfg.debugger compiler.cfg.def-use sets kernel
kernel.private fry slots.private vectors sequences.private
math sbufs math.private strings ;
IN: compiler.cfg.optimizer.tests
! Miscellaneous tests

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

@ -1,13 +1,15 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors combinators namespaces
compiler.cfg.tco
compiler.cfg.predecessors
compiler.cfg.useless-blocks
compiler.cfg.height
compiler.cfg.useless-conditionals
compiler.cfg.stack-analysis
compiler.cfg.branch-splitting
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
compiler.cfg.dce
compiler.cfg.branch-folding
compiler.cfg.write-barrier
compiler.cfg.liveness
compiler.cfg.rpo
@ -23,15 +25,20 @@ SYMBOL: check-optimizer?
] when ;
: optimize-cfg ( cfg -- cfg' )
! Note that compute-predecessors has to be called several times.
! The passes that need this document it.
[
optimize-tail-calls
compute-predecessors
delete-useless-blocks
delete-useless-conditionals
normalize-height
split-branches
compute-predecessors
stack-analysis
compute-liveness
alias-analysis
value-numbering
! fold-branches
! compute-predecessors
eliminate-dead-code
eliminate-write-barriers
eliminate-phis

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

@ -8,7 +8,12 @@ TUPLE: vreg { reg-class read-only } { n read-only } ;
SYMBOL: vreg-counter
: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
! Stack locations
! Stack locations -- 'n' is an index starting from the top of the stack
! going down. So 0 is the top of the stack, 1 is what would be the top
! of the stack after a 'drop', and so on.
! ##inc-d and ##inc-r affect locations as follows. Location D 0 before
! an ##inc-d 1 becomes D 1 after ##inc-d 1.
TUPLE: loc { n read-only } ;
TUPLE: ds-loc < loc ;

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

@ -0,0 +1,93 @@
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 compiler.cfg.registers compiler.cfg.debugger
cpu.architecture make assocs
sequences kernel classes ;
[
{ D 0 }
{ V int-regs 0 V int-regs 1 }
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
<state> H{ { D 0 V int-regs 0 } } >>locs>vregs
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
[ merge-locs locs>vregs>> keys ] { } make first inputs>>
] unit-test
[
{ D 0 }
##peek
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
[
<state>
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
[ merge-locs locs>vregs>> keys ] { } make drop
] keep first instructions>> first class
] unit-test
[
0 ##inc-d
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
[
<state> -1 >>ds-height
<state> 2array
[ merge-ds-heights ds-height>> ] { } make drop
] keep first instructions>> first class
] unit-test
[
0
{ D 0 }
{ 1 1 }
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
[
<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
[
<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

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

@ -1,65 +1,86 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs sequences accessors fry combinators grouping
sets compiler.cfg compiler.cfg.hats
sets locals compiler.cfg compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.stack-analysis.state ;
IN: compiler.cfg.stack-analysis.merge
! XXX critical edges
: initial-state ( bb states -- state ) 2drop <state> ;
: single-predecessor ( bb states -- state ) nip first clone ;
ERROR: must-equal-failed seq ;
: save-ds-height ( n -- )
dup 0 = [ drop ] [ ##inc-d ] if ;
: must-equal ( seq -- elt )
dup all-equal? [ first ] [ must-equal-failed ] 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 ;
: merge-heights ( state predecessors states -- state )
nip
[ [ ds-height>> ] map must-equal >>ds-height ]
[ [ rs-height>> ] map must-equal >>rs-height ] bi ;
: save-rs-height ( n -- )
dup 0 = [ drop ] [ ##inc-r ] if ;
: insert-peek ( predecessor loc -- vreg )
! XXX critical edges
'[ _ ^^peek ] add-instructions ;
: merge-rs-heights ( state predecessors states -- state )
[ rs-height>> ] map dup all-equal?
[ nip first >>rs-height ]
[ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
: merge-loc ( predecessors locs>vregs loc -- vreg )
: assoc-map-values ( assoc quot -- assoc' )
'[ _ dip ] assoc-map ; inline
: translate-locs ( assoc state -- assoc' )
'[ _ translate-loc ] assoc-map-values ;
: untranslate-locs ( assoc state -- assoc' )
'[ _ untranslate-loc ] assoc-map-values ;
: 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 ;
: 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
[ '[ [ _ ] dip at ] map ] keep
'[ [ ] [ _ insert-peek ] ?if ] 2map
'[ [ ] [ _ _ insert-peek ] ?if ] 2map
dup all-equal? [ first ] [ ^^phi ] if ;
: (merge-locs) ( predecessors assocs -- assoc )
dup [ keys ] map concat prune
[ [ 2nip ] [ merge-loc ] 3bi ] with with
H{ } map>assoc ;
:: merge-locs ( state predecessors states -- state )
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-locs ( state predecessors states -- state )
[ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
: merge-actual-loc ( locs>vregs loc -- vreg )
'[ [ _ ] dip at ] map
: merge-actual-loc ( vregs -- vreg/f )
dup all-equal? [ first ] [ drop f ] if ;
: merge-actual-locs ( state predecessors states -- state )
nip
[ actual-locs>vregs>> ] map
dup [ keys ] map concat prune
[ [ nip ] [ merge-actual-loc ] 2bi ] with
H{ } map>assoc
[ nip ] assoc-filter
>>actual-locs>vregs ;
:: 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 predecessors states -- state )
nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
: merge-changed-locs ( state states -- state )
[ [ changed-locs>> ] keep untranslate-locs ] map assoc-combine
over translate-locs
>>changed-locs ;
ERROR: cannot-merge-poisoned states ;
: multiple-predecessors ( bb states -- state )
dup [ not ] any? [
[ <state> ] 2dip
sift merge-heights
2drop <state>
] [
dup [ poisoned?>> ] any? [
cannot-merge-poisoned
@ -67,10 +88,11 @@ ERROR: cannot-merge-poisoned states ;
[ state new ] 2dip
[ predecessors>> ] dip
{
[ merge-ds-heights ]
[ merge-rs-heights ]
[ merge-locs ]
[ merge-actual-locs ]
[ merge-heights ]
[ merge-changed-locs ]
[ nip merge-actual-locs ]
[ nip merge-changed-locs ]
} 2cleave
] if
] if ;
@ -82,4 +104,4 @@ ERROR: cannot-merge-poisoned states ;
{ 0 [ initial-state ] }
{ 1 [ single-predecessor ] }
[ drop multiple-predecessors ]
} case ;
} case ;

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

@ -2,39 +2,21 @@ USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization
compiler.cfg.predecessors compiler.cfg.stack-analysis
compiler.cfg.instructions sequences kernel tools.test accessors
sequences.private alien math combinators.private compiler.cfg
compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo
compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
sets namespaces ;
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
: check-for-redundant-ops ( cfg -- )
[
instructions>>
[
[ ##peek? ] filter [ loc>> ] map duplicates empty?
[ "Redundant peeks" throw ] unless
] [
[ ##replace? ] filter [ loc>> ] map duplicates empty?
[ "Redundant replaces" throw ] unless
] bi
] each-basic-block ;
: test-stack-analysis ( quot -- cfg )
dup cfg? [ test-cfg first ] unless
compute-predecessors
delete-useless-blocks
delete-useless-conditionals
normalize-height
stack-analysis
dup check-cfg
dup check-for-redundant-ops ;
dup check-cfg ;
: linearize ( cfg -- mr )
flatten-cfg instructions>> ;
local-only? off
[ ] [ [ ] test-stack-analysis drop ] unit-test
! Only peek once
@ -113,3 +95,110 @@ local-only? off
[ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
[ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
] unit-test
! Correct height tracking
[ t ] [
[ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
reverse-post-order 3 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 instructions>> second 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 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 3 swap nth
instructions>> [ ##peek? ] filter [ loc>> ] map
{ R 0 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 instructions>> [ ##peek? ] find nip loc>>
] unit-test

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

@ -13,39 +13,23 @@ compiler.cfg.stack-analysis.state
compiler.cfg.stack-analysis.merge ;
IN: compiler.cfg.stack-analysis
! Convert stack operations to register operations
GENERIC: height-for ( loc -- n )
M: ds-loc height-for drop state get ds-height>> ;
M: rs-loc height-for drop state get rs-height>> ;
: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline
GENERIC: translate-loc ( loc -- loc' )
M: ds-loc translate-loc (translate-loc) - <ds-loc> ;
M: rs-loc translate-loc (translate-loc) - <rs-loc> ;
GENERIC: untranslate-loc ( loc -- loc' )
M: ds-loc untranslate-loc (translate-loc) + <ds-loc> ;
M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
: redundant-replace? ( vreg loc -- ? )
dup untranslate-loc n>> 0 <
dup state get untranslate-loc n>> 0 <
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
: save-changed-locs ( state -- )
[ changed-locs>> ] [ locs>vregs>> ] bi '[
_ at swap 2dup redundant-replace?
[ 2drop ] [ untranslate-loc ##replace ] if
] assoc-each ;
[ changed-locs>> keys ] [ locs>vregs>> ] bi '[
dup _ at swap 2dup redundant-replace?
[ 2drop ] [ state get untranslate-loc ##replace ] if
] each ;
ERROR: poisoned-state state ;
: sync-state ( -- )
state get {
[ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
[ ds-height>> save-ds-height ]
[ rs-height>> save-rs-height ]
[ save-changed-locs ]
[ clear-state ]
} cleave ;
@ -55,18 +39,17 @@ ERROR: poisoned-state state ;
! Abstract interpretation
GENERIC: visit ( insn -- )
: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ;
M: ##inc-d visit
n>> state get [ + ] change-ds-height drop ;
M: ##inc-d visit [ , ] [ n>> adjust-ds ] bi ;
: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;
M: ##inc-r visit [ , ] [ n>> adjust-rs ] bi ;
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
##effect ;
##no-tco ;
M: neutral-insn visit , ;
@ -77,17 +60,12 @@ UNION: sync-if-back-edge
##dispatch
##loop-entry ;
SYMBOL: local-only?
t local-only? set-global
: back-edge? ( from to -- ? )
[ number>> ] bi@ > ;
: sync-state? ( -- ? )
basic-block get successors>>
[ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any?
local-only? get or ;
[ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;
M: sync-if-back-edge visit
sync-state? [ sync-state ] when , ;
@ -97,20 +75,16 @@ M: sync-if-back-edge visit
[ ##copy ] [ swap copies get set-at ] 2bi ;
M: ##peek visit
dup
[ dst>> ] [ loc>> translate-loc ] bi
dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ;
[ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg
[ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ;
M: ##replace visit
[ src>> resolve ] [ loc>> translate-loc ] bi
[ src>> resolve ] [ loc>> state get translate-loc ] bi
record-replace ;
M: ##copy visit
[ call-next-method ] [ record-copy ] bi ;
M: ##call visit
[ call-next-method ] [ height>> adjust-ds ] bi ;
! Instructions that poison the stack state
UNION: poison-insn
##jump
@ -133,21 +107,11 @@ UNION: kill-vreg-insn
##fixnum-add
##fixnum-sub
##alien-invoke
##alien-indirect ;
##alien-indirect
##alien-callback ;
M: kill-vreg-insn visit sync-state , ;
: visit-alien-node ( node -- )
params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-ds ;
M: ##alien-invoke visit
[ call-next-method ] [ visit-alien-node ] bi ;
M: ##alien-indirect visit
[ call-next-method ] [ visit-alien-node ] bi ;
M: ##alien-callback visit , ;
! Maps basic-blocks to states
SYMBOLS: state-in state-out ;

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

@ -1,11 +1,14 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets math ;
USING: kernel accessors namespaces assocs sets math
compiler.cfg.registers ;
IN: compiler.cfg.stack-analysis.state
TUPLE: state
locs>vregs actual-locs>vregs changed-locs
ds-height rs-height poisoned? ;
{ ds-height integer }
{ rs-height integer }
poisoned? ;
: <state> ( -- state )
state new
@ -33,11 +36,14 @@ M: state clone
dup changed-loc state get locs>vregs>> set-at ;
: clear-state ( state -- )
[ locs>vregs>> clear-assoc ]
[ actual-locs>vregs>> clear-assoc ]
[ changed-locs>> clear-assoc ]
tri ;
0 >>ds-height 0 >>rs-height
[ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri
[ clear-assoc ] tri@ ;
: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ;
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> ;
: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;
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> ;

85
basis/compiler/cfg/tco/tco.factor Normal file
View File

@ -0,0 +1,85 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit kernel math
namespaces sequences fry combinators
compiler.cfg
compiler.cfg.rpo
compiler.cfg.hats
compiler.cfg.instructions ;
IN: compiler.cfg.tco
! Tail call optimization. You must run compute-predecessors after this
: return? ( bb -- ? )
skip-empty-blocks
instructions>> {
[ length 2 = ]
[ first ##epilogue? ]
[ second ##return? ]
} 1&& ;
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
: tail-call? ( bb -- ? )
{
[ instructions>> { [ length 2 >= ] [ last ##branch? ] } 1&& ]
[ successors>> first return? ]
} 1&& ;
: word-tail-call? ( bb -- ? )
instructions>> penultimate ##call? ;
: convert-tail-call ( bb quot: ( insn -- tail-insn ) -- )
'[
instructions>>
[ pop* ] [ pop ] [ ] tri
[ [ \ ##epilogue new-insn ] dip push ]
[ _ dip push ] bi
]
[ successors>> delete-all ]
bi ; inline
: convert-word-tail-call ( bb -- )
[ word>> \ ##jump new-insn ] convert-tail-call ;
: loop-tail-call? ( bb -- ? )
instructions>> penultimate
{ [ ##call? ] [ word>> cfg get label>> eq? ] } 1&& ;
: convert-loop-tail-call ( bb -- )
! If a word calls itself, this becomes a loop in the CFG.
[ instructions>> [ pop* ] [ pop* ] [ [ \ ##branch new-insn ] dip push ] tri ]
[ successors>> delete-all ]
[ [ cfg get entry>> successors>> first ] dip successors>> push ]
tri ;
: fixnum-tail-call? ( bb -- ? )
instructions>> penultimate
{ [ ##fixnum-add? ] [ ##fixnum-sub? ] [ ##fixnum-mul? ] } 1|| ;
GENERIC: convert-fixnum-tail-call* ( src1 src2 insn -- insn' )
M: ##fixnum-add convert-fixnum-tail-call* drop \ ##fixnum-add-tail new-insn ;
M: ##fixnum-sub convert-fixnum-tail-call* drop \ ##fixnum-sub-tail new-insn ;
M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn ;
: convert-fixnum-tail-call ( bb -- )
[
[ src1>> ] [ src2>> ] [ ] tri
convert-fixnum-tail-call*
] convert-tail-call ;
: optimize-tail-call ( bb -- )
dup tail-call? [
{
{ [ dup loop-tail-call? ] [ convert-loop-tail-call ] }
{ [ dup word-tail-call? ] [ convert-word-tail-call ] }
{ [ dup fixnum-tail-call? ] [ convert-fixnum-tail-call ] }
[ drop ]
} cond
] [ drop ] if ;
: optimize-tail-calls ( cfg -- cfg' )
dup cfg set
dup [ optimize-tail-call ] each-basic-block
f >>post-order ;

11
basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor
View File

@ -1,11 +0,0 @@
IN: compiler.cfg.useless-blocks.tests
USING: fry kernel sequences compiler.cfg.useless-blocks compiler.cfg.checker
compiler.cfg.debugger compiler.cfg.predecessors tools.test ;
{
[ [ drop 1 ] when ]
[ [ drop 1 ] unless ]
} [
[ [ ] ] dip
'[ _ test-cfg first compute-predecessors delete-useless-blocks check-cfg ] unit-test
] each

62
basis/compiler/cfg/useless-blocks/useless-blocks.factor
View File

@ -1,62 +0,0 @@
! 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.useless-blocks
: update-predecessor-for-delete ( bb -- )
! We have to replace occurrences of bb with bb's successor
! in bb's predecessor's list of successors.
dup predecessors>> first [
[
2dup eq? [ drop successors>> first ] [ nip ] if
] with map
] change-successors drop ;
: update-successor-for-delete ( 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-for-delete ]
[ update-successor-for-delete ]
bi ;
: delete-basic-block? ( bb -- ? )
{
[ instructions>> length 1 = ]
[ predecessors>> length 1 = ]
[ successors>> length 1 = ]
[ instructions>> first ##branch? ]
} 1&& ;
: delete-useless-blocks ( cfg -- cfg' )
dup [
dup delete-basic-block? [ delete-basic-block ] [ drop ] if
] each-basic-block
f >>post-order ;
: delete-conditional? ( bb -- ? )
dup instructions>> [ drop f ] [
last class {
##compare-branch
##compare-imm-branch
##compare-float-branch
} memq? [ successors>> first2 eq? ] [ drop f ] if
] if-empty ;
: delete-conditional ( bb -- )
dup successors>> first 1vector >>successors
[ but-last \ ##branch new-insn suffix ] change-instructions
drop ;
: delete-useless-conditionals ( cfg -- cfg' )
dup [
dup delete-conditional? [ delete-conditional ] [ drop ] if
] each-basic-block
f >>post-order ;

0
basis/compiler/cfg/useless-blocks/summary.txt → basis/compiler/cfg/useless-conditionals/summary.txt
View File

21
basis/compiler/cfg/useless-conditionals/useless-conditionals.factor Normal file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences math combinators combinators.short-circuit
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.useless-conditionals
: delete-conditional? ( bb -- ? )
{
[ instructions>> last class { ##compare-branch ##compare-imm-branch ##compare-float-branch } memq? ]
[ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
} 1&& ;
: delete-conditional ( bb -- )
[ first skip-empty-blocks 1vector ] change-successors
instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ;
: delete-useless-conditionals ( cfg -- cfg' )
dup [
dup delete-conditional? [ delete-conditional ] [ drop ] if
] each-basic-block
f >>post-order ;

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

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

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

@ -1,12 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences layouts accessors combinators namespaces
math fry
compiler.cfg.hats
compiler.cfg.instructions
USING: accessors combinators combinators.short-circuit
compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.value-numbering.expressions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.simplify
compiler.cfg.value-numbering.expressions ;
compiler.cfg.value-numbering.simplify fry kernel layouts math
namespaces sequences ;
IN: compiler.cfg.value-numbering.rewrite
GENERIC: rewrite ( insn -- insn' )
@ -19,8 +18,10 @@ M: ##mul-imm rewrite
: ##branch-t? ( insn -- ? )
dup ##compare-imm-branch? [
[ cc>> cc/= eq? ]
[ src2>> \ f tag-number eq? ] bi and
{
[ cc>> cc/= eq? ]
[ src2>> \ f tag-number eq? ]
} 1&&
] [ drop f ] if ; inline
: rewrite-boolean-comparison? ( insn -- ? )
@ -47,9 +48,10 @@ M: ##mul-imm rewrite
: rewrite-tagged-comparison? ( insn -- ? )
#! Are we comparing two tagged fixnums? Then untag them.
[ src1>> vreg>expr tag-fixnum-expr? ]
[ src2>> tag-mask get bitand 0 = ]
bi and ; inline
{
[ src1>> vreg>expr tag-fixnum-expr? ]
[ src2>> tag-mask get bitand 0 = ]
} 1&& ; inline
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
[ src1>> vreg>expr in1>> vn>vreg ]
@ -89,10 +91,11 @@ M: ##compare rewrite
] when ;
: rewrite-redundant-comparison? ( insn -- ? )
[ src1>> vreg>expr compare-expr? ]
[ src2>> \ f tag-number = ]
[ cc>> { cc= cc/= } memq? ]
tri and and ; inline
{
[ src1>> vreg>expr compare-expr? ]
[ src2>> \ f tag-number = ]
[ cc>> { cc= cc/= } memq? ]
} 1&& ; inline
: rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
@ -114,4 +117,20 @@ M: ##compare-imm rewrite
] when
] when ;
: combine-add-imm? ( insn -- ? )
{
[ src1>> vreg>expr op>> \ ##add-imm = ]
[ src2>> number? ]
} 1&& ;
: combine-add-imm ( dst src n -- insn )
[ vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ] dip
+ \ ##add-imm new-insn ;
M: ##add-imm rewrite
dup combine-add-imm? [
[ dst>> ] [ src1>> ] [ src2>> ] tri combine-add-imm
dup number-values
] when ;
M: insn rewrite ;

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

@ -67,6 +67,8 @@ SYMBOL: labels
: lookup-label ( id -- label )
labels get [ drop <label> ] cache ;
M: ##no-tco generate-insn drop ;
M: ##load-immediate generate-insn
[ dst>> register ] [ val>> ] bi %load-immediate ;

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

@ -29,13 +29,15 @@ M: x86.32 temp-reg-2 EDX ;
M:: x86.32 %dispatch ( src temp -- )
! Load jump table base.
src HEX: ffffffff ADD
temp src HEX: ffffffff [+] LEA
building get length cell - :> start
0 rc-absolute-cell rel-here
! Go
src HEX: 7f [+] JMP
temp HEX: 7f [+] JMP
building get length :> end
! Fix up the displacement above
cell code-alignment
[ 7 + building get dup pop* push ]
[ end start - + building get dup pop* push ]
[ align-code ]
bi ;

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

@ -23,15 +23,17 @@ M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M:: x86.64 %dispatch ( src temp -- )
building get length :> start
! Load jump table base.
temp HEX: ffffffff MOV
0 rc-absolute-cell rel-here
! Add jump table base
src temp ADD
src HEX: 7f [+] JMP
temp src ADD
temp HEX: 7f [+] JMP
building get length :> end
! Fix up the displacement above
cell code-alignment
[ 15 + building get dup pop* push ]
[ end start - 2 - + building get dup pop* push ]
[ align-code ]
bi ;

16
basis/disjoint-sets/disjoint-sets-tests.factor Normal file
View File

@ -0,0 +1,16 @@
IN: disjoint-sets.testes
USING: tools.test disjoint-sets namespaces slots.private ;
SYMBOL: +blah+
-405534154 +blah+ 1 set-slot
SYMBOL: uf
[ ] [
<disjoint-set> uf set
+blah+ uf get add-atom
19026 uf get add-atom
19026 +blah+ uf get equate
] unit-test
[ 2 ] [ 19026 uf get equiv-set-size ] unit-test

6
basis/math/primes/factors/factors-docs.factor
View File

@ -1,7 +1,7 @@
USING: help.markup help.syntax math sequences ;
IN: math.primes.factors
{ factors group-factors unique-factors } related-words
{ divisors factors group-factors unique-factors } related-words
HELP: factors
{ $values { "n" "a positive integer" } { "seq" sequence } }
@ -21,3 +21,7 @@ HELP: unique-factors
HELP: totient
{ $values { "n" "a positive integer" } { "t" integer } }
{ $description { "Return the number of integers between 1 and " { $snippet "n-1" } " that are relatively prime to " { $snippet "n" } "." } } ;
HELP: divisors
{ $values { "n" "a positive integer" } { "seq" sequence } }
{ $description { "Return the ordered list of divisors of " { $snippet "n" } ", including 1 and " { $snippet "n" } "." } } ;

4
basis/math/primes/factors/factors-tests.factor
View File

@ -1,4 +1,4 @@
USING: math.primes.factors tools.test ;
USING: math.primes.factors sequences tools.test ;
{ { 999983 999983 1000003 } } [ 999969000187000867 factors ] unit-test
{ { } } [ -5 factors ] unit-test
@ -8,3 +8,5 @@ USING: math.primes.factors tools.test ;
{ 0 } [ 1 totient ] unit-test
{ { 425612003 } } [ 425612003 factors ] unit-test
{ { 13 4253 15823 32472893749823741 } } [ 28408516453955558205925627 factors ] unit-test
{ { 1 2 3 4 6 8 12 24 } } [ 24 divisors ] unit-test
{ 24 } [ 360 divisors length ] unit-test

6
basis/math/primes/factors/factors.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007-2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel make math math.functions
math.primes sequences ;
math.primes math.ranges sequences sequences.product sorting ;
IN: math.primes.factors
<PRIVATE
@ -41,3 +41,7 @@ PRIVATE>
{ [ dup 2 < ] [ drop 0 ] }
[ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / * ]
} cond ; foldable
: divisors ( n -- seq )
group-factors [ first2 [0,b] [ ^ ] with map ] map
[ product ] product-map natural-sort ;

2
basis/math/vectors/vectors-tests.factor
View File

@ -16,3 +16,5 @@ USING: math.vectors tools.test ;
[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test
[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test
[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test

8
basis/tools/scaffold/scaffold.factor
View File

@ -266,6 +266,14 @@ PRIVATE>
[ nip require ]
} 2cleave ;
: scaffold-core ( string -- ) "resource:core" swap scaffold-vocab ;
: scaffold-basis ( string -- ) "resource:basis" swap scaffold-vocab ;
: scaffold-extra ( string -- ) "resource:extra" swap scaffold-vocab ;
: scaffold-work ( string -- ) "resource:work" swap scaffold-vocab ;
<PRIVATE
: tests-file-string ( vocab -- string )

5
extra/cursors/cursors-tests.factor
View File

@ -37,3 +37,8 @@ IN: cursors.tests
[ { 111 222 } ]
[ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ] unit-test
: test-3map ( -- seq )
{ 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ;
[ { 111 222 } ] [ test-3map ] unit-test

9
extra/cursors/cursors.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generalizations kernel math sequences
sequences.private ;
sequences.private fry ;
IN: cursors
GENERIC: cursor-done? ( cursor -- ? )
@ -127,12 +127,13 @@ M: to-sequence cursor-write
: 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline
: find-done3? ( cursor1 cursor2 cursor3 quot -- ? )
3 nover 3array [ cursor-done? ] any?
[ 4 ndrop t ] [ [ [ cursor-get-unsafe ] tri@ ] dip call ] if ; inline
[ 3 ndrop t ] swap '[ [ cursor-get-unsafe ] tri@ @ ]
[ 3 ndup 3 narray [ cursor-done? ] any? ] 2dip if ; inline
: cursor-until3 ( cursor cursor quot -- )
[ find-done3? not ]
[ drop [ cursor-advance ] tri@ ] bi-curry bi-curry bi-curry bi-curry while ; inline
[ drop [ cursor-advance ] tri@ ]
bi-curry bi-curry bi-curry bi-curry while ; inline
: cursor-each3 ( cursor cursor quot -- )
[ f ] compose cursor-until3 ; inline

5
extra/histogram/histogram.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences assocs ;
USING: kernel sequences assocs fry ;
IN: histogram
<PRIVATE
@ -24,3 +24,6 @@ PRIVATE>
: histogram ( seq -- hashtable )
[ inc-at ] sequence>hashtable ;
: collect-values ( seq quot: ( obj hashtable -- ) -- hash )
'[ [ dup @ ] dip push-at ] sequence>hashtable ; inline

42
extra/webapps/imagebin/imagebin.factor
View File

@ -1,39 +1,45 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel furnace.actions html.forms
http.server.dispatchers db db.tuples db.types urls
furnace.redirection multiline http namespaces ;
USING: accessors furnace.actions furnace.redirection
html.forms http http.server http.server.dispatchers
io.directories io.encodings.utf8 io.files io.pathnames
kernel math.parser multiline namespaces sequences urls ;
IN: webapps.imagebin
TUPLE: imagebin < dispatcher ;
TUPLE: image id path ;
image "IMAGE" {
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "path" "PATH" { VARCHAR 256 } +not-null+ }
} define-persistent
TUPLE: imagebin < dispatcher path n ;
: <uploaded-image-action> ( -- action )
<page-action>
{ imagebin "uploaded-image" } >>template ;
SYMBOL: my-post-data
: next-image-path ( -- path )
imagebin get
[ path>> ] [ n>> number>string ] bi append-path ;
M: imagebin call-responder*
[ imagebin set ] [ call-next-method ] bi ;
: move-image ( mime-file -- )
next-image-path
[ [ temporary-path>> ] dip move-file ]
[ [ filename>> ] dip ".txt" append utf8 set-file-contents ] 2bi ;
: <upload-image-action> ( -- action )
<page-action>
{ imagebin "upload-image" } >>template
[
! request get post-data>> my-post-data set-global
! image new
! "file" value
! insert-tuple
"file1" param [ move-image ] when*
"file2" param [ move-image ] when*
"file3" param [ move-image ] when*
"uploaded-image" <redirect>
] >>submit ;
: <imagebin> ( -- responder )
: <imagebin> ( image-directory -- responder )
imagebin new-dispatcher
swap [ make-directories ] [ >>path ] bi
0 >>n
<upload-image-action> "" add-responder
<upload-image-action> "upload-image" add-responder
<uploaded-image-action> "uploaded-image" add-responder ;
"resource:images" <imagebin> main-responder set-global

2
extra/webapps/imagebin/uploaded-image.xml
View File

@ -2,6 +2,6 @@
<html>
<head><title>Uploaded</title></head>
<body>
hi from uploaded-image
You uploaded something!
</body>
</html>