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

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

db4
Joe Groff 2009-07-07 15:11:13 -05:00
parent 01d344fb46 dafdbe13c9
commit fbdcb61763
49 changed files with 1336 additions and 442 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
basis/alien/inline/compiler/compiler.factor
View File

@ -21,23 +21,33 @@ SYMBOL: C++
{ C++ [ ".cpp" ] } { C++ [ ".cpp" ] }
} case ; } case ;
: compiler ( lang -- str )
{
{ C [ "gcc" ] }
{ C++ [ "g++" ] }
} case ;
: link-command ( in out lang -- descr )
compiler os {
{ [ dup linux? ]
[ drop { "-shared" "-o" } ] }
{ [ dup macosx? ]
[ drop { "-g" "-prebind" "-dynamiclib" "-o" } ] }
[ name>> "unimplemented for: " prepend throw ]
} cond swap prefix prepend prepend ;
:: compile-to-object ( lang contents name -- ) :: compile-to-object ( lang contents name -- )
name ".o" append temp-file name ".o" append temp-file
contents name lang src-suffix append temp-file contents name lang src-suffix append temp-file
[ ascii set-file-contents ] keep 2array [ ascii set-file-contents ] keep 2array
{ "gcc" "-fPIC" "-c" "-o" } prepend try-process ; { "-fPIC" "-c" "-o" } lang compiler prefix prepend
try-process ;
: link-object ( args name -- ) :: link-object ( lang args name -- )
[ "lib" prepend library-suffix append ] [ ".o" append ] bi args name [ "lib" prepend library-suffix append ]
[ temp-file ] bi@ 2array [ ".o" append ] bi [ temp-file ] bi@ 2array
os { lang link-command try-process ;
{ [ dup linux? ]
[ drop { "gcc" "-shared" "-o" } ] }
{ [ dup macosx? ]
[ drop { "gcc" "-g" "-prebind" "-dynamiclib" "-o" } ] }
[ name>> "unimplemented for: " prepend throw ]
} cond prepend prepend try-process ;
:: compile-to-library ( lang args contents name -- ) :: compile-to-library ( lang args contents name -- )
lang contents name compile-to-object lang contents name compile-to-object
args name link-object ; lang args name link-object ;

59
basis/alien/inline/inline.factor
View File

@ -1,9 +1,11 @@
! Copyright (C) 2009 Jeremy Hughes. ! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.inline.compiler alien.libraries USING: accessors alien.inline.compiler alien.inline.types
alien.parser arrays fry generalizations io.files io.files.info alien.libraries alien.parser arrays assocs effects fry
io.files.temp kernel lexer math.order multiline namespaces generalizations grouping io.files io.files.info io.files.temp
sequences system vocabs.loader vocabs.parser words ; kernel lexer math math.order math.ranges multiline namespaces
sequences splitting strings system vocabs.loader
vocabs.parser words ;
IN: alien.inline IN: alien.inline
<PRIVATE <PRIVATE
@ -12,21 +14,34 @@ SYMBOL: library-is-c++
SYMBOL: compiler-args SYMBOL: compiler-args
SYMBOL: c-strings SYMBOL: c-strings
: return-library-function-params ( -- return library function params ) : function-types-effect ( -- function types effect )
scan c-library get scan ")" parse-tokens scan scan swap ")" parse-tokens
[ "(" subseq? not ] filter [ [ "(" subseq? not ] filter swap parse-arglist ;
[ dup CHAR: - = [ drop CHAR: space ] when ] map
] 3dip ;
: factor-function ( return library function params -- ) : arg-list ( types -- params )
[ dup "const " head? [ 6 tail ] when ] 3dip CHAR: a swap length CHAR: a + [a,b]
make-function define-declared ; [ 1string ] map ;
: c-function-string ( return library function params -- str ) : factor-function ( function types effect -- word quot effect )
[ nip ] dip annotate-effect [ c-library get ] 3dip
" " join "(" prepend ")" append 3array " " join [ [ factorize-type ] map ] dip
types-effect>params-return factorize-type -roll
concat make-function ;
: prototype-string ( function types effect -- str )
[ [ cify-type ] map ] dip
types-effect>params-return cify-type -rot
[ " " join ] map ", " join
"(" prepend ")" append 3array " " join
library-is-c++ get [ "extern \"C\" " prepend ] when ; library-is-c++ get [ "extern \"C\" " prepend ] when ;
: prototype-string' ( function types return -- str )
[ dup arg-list ] <effect> prototype-string ;
: append-function-body ( prototype-str -- str )
" {\n" append parse-here append "\n}\n" append ;
: library-path ( -- str ) : library-path ( -- str )
"lib" c-library get library-suffix "lib" c-library get library-suffix
3array concat temp-file ; 3array concat temp-file ;
@ -53,10 +68,14 @@ PRIVATE>
compile-library? [ compile-library ] when compile-library? [ compile-library ] when
c-library get library-path "cdecl" add-library ; c-library get library-path "cdecl" add-library ;
: define-c-function ( return library function params -- ) : define-c-function ( function types effect -- )
[ factor-function ] 4 nkeep c-function-string [ factor-function define-declared ] 3keep prototype-string
" {\n" append parse-here append "\n}\n" append append-function-body c-strings get push ;
c-strings get push ;
: define-c-function' ( function effect -- )
[ in>> ] keep [ factor-function define-declared ] 3keep
out>> prototype-string'
append-function-body c-strings get push ;
: define-c-link ( str -- ) : define-c-link ( str -- )
"-l" prepend compiler-args get push ; "-l" prepend compiler-args get push ;
@ -83,6 +102,6 @@ SYNTAX: C-LINK/FRAMEWORK: scan define-c-link/framework ;
SYNTAX: C-INCLUDE: scan define-c-include ; SYNTAX: C-INCLUDE: scan define-c-include ;
SYNTAX: C-FUNCTION: SYNTAX: C-FUNCTION:
return-library-function-params define-c-function ; function-types-effect define-c-function ;
SYNTAX: ;C-LIBRARY compile-c-library ; SYNTAX: ;C-LIBRARY compile-c-library ;

1
basis/alien/inline/types/authors.txt Normal file
View File

@ -0,0 +1 @@
Jeremy Hughes

47
basis/alien/inline/types/types.factor Normal file
View File

@ -0,0 +1,47 @@
! Copyright (C) 2009 Jeremy Hughes.
! 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 ;
IN: alien.inline.types
: factorize-type ( str -- str' )
"const-" ?head drop
"unsigned-" ?head [ "u" prepend ] when
"long-" ?head [ "long" prepend ] when ;
: cify-type ( str -- str' )
{ { CHAR: - CHAR: space } } substitute ;
: const-type? ( str -- ? )
"const-" head? ;
MEMO: resolved-primitives ( -- seq )
primitive-types [ resolve-typedef ] map ;
: primitive-type? ( type -- ? )
[
factorize-type resolve-typedef [ resolved-primitives ] dip
'[ _ = ] any?
] [ 2drop f ] recover ;
: pointer? ( type -- ? )
[ "*" tail? ] [ "&" tail? ] bi or ;
: type-sans-pointer ( type -- type' )
[ '[ _ = ] "*&" swap any? ] trim-tail ;
: pointer-to-primitive? ( type -- ? )
{ [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;
: types-effect>params-return ( types effect -- params return )
[ in>> zip ]
[ nip out>> dup length 0 > [ first ] [ drop "void" ] if ]
2bi ;
: annotate-effect ( types effect -- types effect' )
[ in>> ] [ out>> ] bi [
zip
[ over pointer-to-primitive? [ ">" prepend ] when ]
assoc-map unzip
] dip <effect> ;

4
basis/bit-vectors/bit-vectors-docs.factor
View File

@ -22,11 +22,11 @@ HELP: bit-vector
{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ; { $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
HELP: <bit-vector> HELP: <bit-vector>
{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } } { $values { "capacity" "a positive integer specifying initial capacity" } { "vector" bit-vector } }
{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ; { $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;
HELP: >bit-vector HELP: >bit-vector
{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } } { $values { "seq" "a sequence" } { "vector" bit-vector } }
{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ; { $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
HELP: ?V{ HELP: ?V{

31
basis/bit-vectors/bit-vectors.factor
View File

@ -1,38 +1,15 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences USING: arrays kernel kernel.private math sequences
sequences.private growable bit-arrays prettyprint.custom sequences.private growable bit-arrays prettyprint.custom
parser accessors ; parser accessors vectors.functor classes.parser ;
IN: bit-vectors IN: bit-vectors
TUPLE: bit-vector << "bit-vector" create-class-in \ bit-array \ <bit-array> define-vector >>
{ underlying bit-array initial: ?{ } }
{ length array-capacity } ;
: <bit-vector> ( n -- bit-vector )
<bit-array> 0 bit-vector boa ; inline
: >bit-vector ( seq -- bit-vector )
T{ bit-vector f ?{ } 0 } clone-like ;
M: bit-vector like
drop dup bit-vector? [
dup bit-array?
[ dup length bit-vector boa ] [ >bit-vector ] if
] unless ;
M: bit-vector new-sequence
drop [ <bit-array> ] [ >fixnum ] bi bit-vector boa ;
M: bit-vector equal?
over bit-vector? [ sequence= ] [ 2drop f ] if ;
M: bit-array new-resizable drop <bit-vector> ;
INSTANCE: bit-vector growable
SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ; SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;
M: bit-vector contract 2drop ;
M: bit-vector >pprint-sequence ; M: bit-vector >pprint-sequence ;
M: bit-vector pprint-delims drop \ ?V{ \ } ; M: bit-vector pprint-delims drop \ ?V{ \ } ;
M: bit-vector pprint* pprint-object ; M: bit-vector pprint* pprint-object ;

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

@ -261,4 +261,3 @@ INSN: _reload dst class n ;
INSN: _copy dst src class ; INSN: _copy dst src class ;
INSN: _spill-counts counts ; INSN: _spill-counts counts ;
SYMBOL: spill-temp

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

@ -9,11 +9,6 @@ compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.state ; compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.allocation IN: compiler.cfg.linear-scan.allocation
: free-positions ( new -- assoc )
vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
: active-positions ( new assoc -- ) : active-positions ( new assoc -- )
[ vreg>> active-intervals-for ] dip [ vreg>> active-intervals-for ] dip
'[ [ 0 ] dip reg>> _ add-use-position ] each ; '[ [ 0 ] dip reg>> _ add-use-position ] each ;
@ -21,7 +16,7 @@ IN: compiler.cfg.linear-scan.allocation
: inactive-positions ( new assoc -- ) : inactive-positions ( new assoc -- )
[ [ vreg>> inactive-intervals-for ] keep ] dip [ [ vreg>> inactive-intervals-for ] keep ] dip
'[ '[
[ _ relevant-ranges intersect-live-ranges ] [ reg>> ] bi [ _ relevant-ranges intersect-live-ranges 1/0. or ] [ reg>> ] bi
_ add-use-position _ add-use-position
] each ; ] each ;
@ -33,12 +28,6 @@ IN: compiler.cfg.linear-scan.allocation
: no-free-registers? ( result -- ? ) : no-free-registers? ( result -- ? )
second 0 = ; inline second 0 = ; inline
: register-available? ( new result -- ? )
[ end>> ] [ second ] bi* < ; inline
: register-available ( new result -- )
first >>reg add-active ;
: register-partially-available ( new result -- ) : register-partially-available ( new result -- )
[ second split-before-use ] keep [ second split-before-use ] keep
'[ _ register-available ] [ add-unhandled ] bi* ; '[ _ register-available ] [ add-unhandled ] bi* ;

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

@ -9,15 +9,15 @@ IN: compiler.cfg.linear-scan.allocation.coalescing
: active-interval ( vreg -- live-interval ) : active-interval ( vreg -- live-interval )
dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ; dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
: intersects-inactive-intervals? ( live-interval -- ? ) : avoids-inactive-intervals? ( live-interval -- ? )
dup vreg>> inactive-intervals-for dup vreg>> inactive-intervals-for
[ relevant-ranges intersect-live-ranges 1/0. = ] with all? ; [ intervals-intersect? not ] with all? ;
: coalesce? ( live-interval -- ? ) : coalesce? ( live-interval -- ? )
{ {
[ copy-from>> active-interval ] [ copy-from>> active-interval ]
[ [ start>> ] [ copy-from>> active-interval end>> ] bi = ] [ [ start>> ] [ copy-from>> active-interval end>> ] bi = ]
[ intersects-inactive-intervals? ] [ avoids-inactive-intervals? ]
} 1&& ; } 1&& ;
: coalesce ( live-interval -- ) : coalesce ( live-interval -- )

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

@ -1,23 +1,13 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals USING: accessors arrays assocs combinators fry hints kernel locals
math sequences sets sorting splitting compiler.utilities namespaces math sequences sets sorting splitting namespaces
combinators.short-circuit compiler.utilities
compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.spilling IN: compiler.cfg.linear-scan.allocation.spilling
: find-use ( live-interval n quot -- elt )
[ uses>> ] 2dip curry find nip ; inline
: interval-to-spill ( active-intervals current -- live-interval )
#! We spill the interval with the most distant use location.
#! If an active interval has no more use positions, find-use
#! returns f. This occurs if the interval is a split. In
#! this case, we prefer to spill this interval always.
start>> '[ dup _ [ >= ] find-use 1/0. or ] { } map>assoc
alist-max first ;
ERROR: bad-live-ranges interval ; ERROR: bad-live-ranges interval ;
: check-ranges ( live-interval -- ) : check-ranges ( live-interval -- )
@ -47,52 +37,108 @@ ERROR: bad-live-ranges interval ;
[ ] [ ]
} 2cleave ; } 2cleave ;
: assign-spill ( live-interval -- live-interval ) : assign-spill ( live-interval -- )
dup vreg>> assign-spill-slot >>spill-to ; dup vreg>> assign-spill-slot >>spill-to drop ;
: assign-reload ( before after -- before after ) : assign-reload ( live-interval -- )
over spill-to>> >>reload-from ; dup vreg>> assign-spill-slot >>reload-from drop ;
: split-and-spill ( new existing -- before after ) : split-and-spill ( live-interval n -- before after )
swap start>> split-for-spill [ assign-spill ] dip assign-reload ; split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ;
: reuse-register ( new existing -- ) : find-use-position ( live-interval new -- n )
[ nip delete-active ] [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ;
[ reg>> >>reg add-active ] 2bi ;
: spill-existing? ( new existing -- ? ) : find-use-positions ( live-intervals new assoc -- )
#! Test if 'new' will be used before 'existing'. '[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ;
over start>> '[ _ [ > ] find-use -1 or ] bi@ < ;
: spill-existing ( new existing -- ) : active-positions ( new assoc -- )
#! Our new interval will be used before the active interval [ [ vreg>> active-intervals-for ] keep ] dip
#! with the most distant use location. Spill the existing find-use-positions ;
#! interval, then process the new interval and the tail end
#! of the existing interval again.
[ reuse-register ]
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2bi ;
: spill-live-out? ( new existing -- ? ) : inactive-positions ( new assoc -- )
[ start>> ] [ uses>> last ] bi* > ; [
[ vreg>> inactive-intervals-for ] keep
[ '[ _ intervals-intersect? ] filter ] keep
] dip
find-use-positions ;
: spill-live-out ( new existing -- ) : spill-status ( new -- use-pos )
#! The existing interval is never used again. Spill it and H{ } clone
#! re-use the register. [ inactive-positions ] [ active-positions ] [ nip ] 2tri
assign-spill >alist alist-max ;
[ reuse-register ]
[ nip add-handled ] 2bi ;
: spill-new ( new existing -- ) : spill-new? ( new pair -- ? )
#! Our new interval will be used after the active interval [ uses>> first ] [ second ] bi* > ;
#! with the most distant use location. Split the new
#! interval, then process both parts of the new interval
#! again.
[ dup split-and-spill add-unhandled ] dip spill-existing ;
: assign-blocked-register ( new -- ) : spill-new ( new pair -- )
[ dup vreg>> active-intervals-for ] keep interval-to-spill { drop
{ [ 2dup spill-live-out? ] [ spill-live-out ] } {
{ [ 2dup spill-existing? ] [ spill-existing ] } [ trim-after-ranges ]
[ spill-new ] [ compute-start/end ]
[ assign-reload ]
[ add-unhandled ]
} cleave ;
: split-intersecting? ( live-interval new reg -- ? )
{ [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ;
: split-live-out ( live-interval -- )
{
[ trim-before-ranges ]
[ compute-start/end ]
[ assign-spill ]
[ add-handled ]
} cleave ;
: split-live-in ( live-interval -- )
{
[ trim-after-ranges ]
[ compute-start/end ]
[ assign-reload ]
[ add-unhandled ]
} cleave ;
: (split-intersecting) ( live-interval new -- )
start>> {
{ [ 2dup [ uses>> last ] dip < ] [ drop split-live-out ] }
{ [ 2dup [ uses>> first ] dip > ] [ drop split-live-in ] }
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ]
} cond ; } cond ;
: (split-intersecting-active) ( active new -- )
[ drop delete-active ]
[ (split-intersecting) ] 2bi ;
: split-intersecting-active ( new reg -- )
[ [ vreg>> active-intervals-for ] keep ] dip
[ '[ _ _ split-intersecting? ] filter ] 2keep drop
'[ _ (split-intersecting-active) ] each ;
: (split-intersecting-inactive) ( inactive new -- )
[ drop delete-inactive ]
[ (split-intersecting) ] 2bi ;
: split-intersecting-inactive ( new reg -- )
[ [ vreg>> inactive-intervals-for ] keep ] dip
[ '[ _ _ split-intersecting? ] filter ] 2keep drop
'[ _ (split-intersecting-inactive) ] each ;
: split-intersecting ( new reg -- )
[ split-intersecting-active ]
[ split-intersecting-inactive ]
2bi ;
: spill-available ( new pair -- )
[ first split-intersecting ] [ register-available ] 2bi ;
: spill-partially-available ( new pair -- )
[ second 1 - split-and-spill add-unhandled ] keep
spill-available ;
: assign-blocked-register ( new -- )
dup spill-status {
{ [ 2dup spill-new? ] [ spill-new ] }
{ [ 2dup register-available? ] [ spill-available ] }
[ spill-partially-available ]
} cond ;

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

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals USING: accessors arrays assocs combinators fry hints kernel locals
math sequences sets sorting splitting math sequences sets sorting splitting namespaces
compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.splitting IN: compiler.cfg.linear-scan.allocation.splitting
@ -32,12 +32,17 @@ IN: compiler.cfg.linear-scan.allocation.splitting
ERROR: splitting-too-early ; ERROR: splitting-too-early ;
ERROR: splitting-too-late ;
ERROR: splitting-atomic-interval ; ERROR: splitting-atomic-interval ;
: check-split ( live-interval n -- ) : check-split ( live-interval n -- )
[ [ start>> ] dip > [ splitting-too-early ] when ] check-allocation? get [
[ drop [ end>> ] [ start>> ] bi - 0 = [ splitting-atomic-interval ] when ] [ [ start>> ] dip > [ splitting-too-early ] when ]
2bi ; inline [ [ end>> ] dip <= [ splitting-too-late ] when ]
[ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ]
2tri
] [ 2drop ] if ; inline
: split-before ( before -- before' ) : split-before ( before -- before' )
f >>spill-to ; inline f >>spill-to ; inline
@ -62,11 +67,12 @@ HINTS: split-interval live-interval object ;
2dup [ compute-start/end ] bi@ ; 2dup [ compute-start/end ] bi@ ;
: insert-use-for-copy ( seq n -- seq' ) : insert-use-for-copy ( seq n -- seq' )
dup 1 + [ nip 1array split1 ] 2keep 2array glue ; [ '[ _ < ] filter ]
[ nip dup 1 + 2array ]
[ 1 + '[ _ > ] filter ]
2tri 3append ;
: split-before-use ( new n -- before after ) : split-before-use ( new n -- before after )
! Find optimal split position
! Insert move instruction
1 - 1 -
2dup swap covers? [ 2dup swap covers? [
[ '[ _ insert-use-for-copy ] change-uses ] keep [ '[ _ insert-use-for-copy ] change-uses ] keep

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

@ -1,10 +1,24 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators cpu.architecture fry heaps USING: accessors assocs combinators cpu.architecture fry heaps
kernel math namespaces sequences vectors kernel math math.order namespaces sequences vectors
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.state IN: compiler.cfg.linear-scan.allocation.state
! Start index of current live interval. We ensure that all
! live intervals added to the unhandled set have a start index
! strictly greater than this one. This ensures that we can catch
! infinite loop situations. We also ensure that all live
! intervals added to the handled set have an end index strictly
! smaller than this one. This helps catch bugs.
SYMBOL: progress
: check-unhandled ( live-interval -- )
start>> progress get <= [ "check-unhandled" throw ] when ; inline
: check-handled ( live-interval -- )
end>> progress get > [ "check-handled" throw ] when ; inline
! Mapping from register classes to sequences of machine registers ! Mapping from register classes to sequences of machine registers
SYMBOL: registers SYMBOL: registers
@ -32,11 +46,14 @@ SYMBOL: inactive-intervals
: add-inactive ( live-interval -- ) : add-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for push ; dup vreg>> inactive-intervals-for push ;
: delete-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for delq ;
! Vector of handled live intervals ! Vector of handled live intervals
SYMBOL: handled-intervals SYMBOL: handled-intervals
: add-handled ( live-interval -- ) : add-handled ( live-interval -- )
handled-intervals get push ; [ check-handled ] [ handled-intervals get push ] bi ;
: finished? ( n live-interval -- ? ) end>> swap < ; : finished? ( n live-interval -- ? ) end>> swap < ;
@ -90,17 +107,8 @@ ERROR: register-already-used live-interval ;
! Minheap of live intervals which still need a register allocation ! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals SYMBOL: unhandled-intervals
! Start index of current live interval. We ensure that all
! live intervals added to the unhandled set have a start index
! strictly greater than ths one. This ensures that we can catch
! infinite loop situations.
SYMBOL: progress
: check-progress ( live-interval -- )
start>> progress get <= [ "No progress" throw ] when ; inline
: add-unhandled ( live-interval -- ) : add-unhandled ( live-interval -- )
[ check-progress ] [ check-unhandled ]
[ dup start>> unhandled-intervals get heap-push ] [ dup start>> unhandled-intervals get heap-push ]
bi ; bi ;
@ -134,3 +142,15 @@ SYMBOL: spill-slots
: init-unhandled ( live-intervals -- ) : init-unhandled ( live-intervals -- )
[ [ start>> ] keep ] { } map>assoc [ [ start>> ] keep ] { } map>assoc
unhandled-intervals get heap-push-all ; unhandled-intervals get heap-push-all ;
! A utility used by register-status and spill-status words
: free-positions ( new -- assoc )
vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
: register-available? ( new result -- ? )
[ end>> ] [ second ] bi* < ; inline
: register-available ( new result -- )
first >>reg add-active ;

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

@ -3,7 +3,9 @@
USING: accessors kernel math assocs namespaces sequences heaps USING: accessors kernel math assocs namespaces sequences heaps
fry make combinators sets locals fry make combinators sets locals
cpu.architecture cpu.architecture
compiler.cfg
compiler.cfg.def-use compiler.cfg.def-use
compiler.cfg.liveness
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation
@ -27,12 +29,6 @@ SYMBOL: unhandled-intervals
: init-unhandled ( live-intervals -- ) : init-unhandled ( live-intervals -- )
[ add-unhandled ] each ; [ add-unhandled ] each ;
! Mapping spill slots to vregs
SYMBOL: spill-slots
: spill-slots-for ( vreg -- assoc )
reg-class>> spill-slots get at ;
! Mapping from basic blocks to values which are live at the start ! Mapping from basic blocks to values which are live at the start
SYMBOL: register-live-ins SYMBOL: register-live-ins
@ -42,17 +38,10 @@ SYMBOL: register-live-outs
: init-assignment ( live-intervals -- ) : init-assignment ( live-intervals -- )
V{ } clone pending-intervals set V{ } clone pending-intervals set
<min-heap> unhandled-intervals set <min-heap> unhandled-intervals set
[ H{ } clone ] reg-class-assoc spill-slots set
H{ } clone register-live-ins set H{ } clone register-live-ins set
H{ } clone register-live-outs set H{ } clone register-live-outs set
init-unhandled ; init-unhandled ;
ERROR: already-spilled ;
: record-spill ( live-interval -- )
[ dup spill-to>> ] [ vreg>> spill-slots-for ] bi
2dup key? [ already-spilled ] [ set-at ] if ;
: insert-spill ( live-interval -- ) : insert-spill ( live-interval -- )
{ {
[ reg>> ] [ reg>> ]
@ -62,7 +51,7 @@ ERROR: already-spilled ;
} cleave f swap \ _spill boa , ; } cleave f swap \ _spill boa , ;
: handle-spill ( live-interval -- ) : handle-spill ( live-interval -- )
dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ; dup spill-to>> [ insert-spill ] [ drop ] if ;
: first-split ( live-interval -- live-interval' ) : first-split ( live-interval -- live-interval' )
dup split-before>> [ first-split ] [ ] ?if ; dup split-before>> [ first-split ] [ ] ?if ;
@ -79,8 +68,7 @@ ERROR: already-spilled ;
} cleave f swap \ _copy boa , ; } cleave f swap \ _copy boa , ;
: handle-copy ( live-interval -- ) : handle-copy ( live-interval -- )
dup [ spill-to>> not ] [ split-next>> ] bi and dup split-next>> [ insert-copy ] [ drop ] if ;
[ insert-copy ] [ drop ] if ;
: expire-old-intervals ( n -- ) : expire-old-intervals ( n -- )
[ pending-intervals get ] dip '[ [ pending-intervals get ] dip '[
@ -88,22 +76,16 @@ ERROR: already-spilled ;
[ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
] filter-here ; ] filter-here ;
ERROR: already-reloaded ;
: record-reload ( live-interval -- )
[ reload-from>> ] [ vreg>> spill-slots-for ] bi
2dup key? [ delete-at ] [ already-reloaded ] if ;
: insert-reload ( live-interval -- ) : insert-reload ( live-interval -- )
{ {
[ reg>> ] [ reg>> ]
[ vreg>> reg-class>> ] [ vreg>> reg-class>> ]
[ reload-from>> ] [ reload-from>> ]
[ end>> ] [ start>> ]
} cleave f swap \ _reload boa , ; } cleave f swap \ _reload boa , ;
: handle-reload ( live-interval -- ) : handle-reload ( live-interval -- )
dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ; dup reload-from>> [ insert-reload ] [ drop ] if ;
: activate-new-intervals ( n -- ) : activate-new-intervals ( n -- )
#! Any live intervals which start on the current instruction #! Any live intervals which start on the current instruction
@ -137,45 +119,51 @@ ERROR: overlapping-registers intervals ;
: active-intervals ( n -- intervals ) : active-intervals ( n -- intervals )
pending-intervals get [ covers? ] with filter pending-intervals get [ covers? ] with filter
check-assignment? get [ check-assignment? get [ dup check-assignment ] when ;
dup check-assignment
] when ;
M: vreg-insn assign-registers-in-insn M: vreg-insn assign-registers-in-insn
dup [ insn#>> active-intervals ] [ all-vregs ] bi dup [ all-vregs ] [ insn#>> active-intervals ] bi
'[ vreg>> _ member? ] filter '[ _ [ vreg>> = ] with find nip ] map
register-mapping register-mapping
>>regs drop ; >>regs drop ;
: compute-live-registers ( n -- assoc )
active-intervals register-mapping ;
: compute-live-spill-slots ( -- assocs )
spill-slots get values first2
[ [ vreg>> swap <spill-slot> ] H{ } assoc-map-as ] bi@
assoc-union ;
: compute-live-values ( n -- assoc )
[ compute-live-spill-slots ] dip compute-live-registers
assoc-union ;
: compute-live-gc-values ( insn -- assoc )
[ insn#>> compute-live-values ] [ temp-vregs ] bi
'[ drop _ memq? not ] assoc-filter ;
M: ##gc assign-registers-in-insn M: ##gc assign-registers-in-insn
! This works because ##gc is always the first instruction
! in a block.
dup call-next-method dup call-next-method
dup compute-live-gc-values >>live-values basic-block get register-live-ins get at >>live-values
drop ; drop ;
M: insn assign-registers-in-insn drop ; M: insn assign-registers-in-insn drop ;
: compute-live-spill-slots ( vregs -- assoc )
spill-slots get '[ _ at dup [ <spill-slot> ] when ] assoc-map ;
: compute-live-registers ( n -- assoc )
active-intervals register-mapping ;
ERROR: bad-live-values live-values ;
: check-live-values ( assoc -- assoc )
check-assignment? get [
dup values [ not ] any? [ bad-live-values ] when
] when ;
: compute-live-values ( vregs n -- assoc )
! If a live vreg is not in active or inactive, then it must have been
! spilled.
[ compute-live-spill-slots ] [ compute-live-registers ] bi*
assoc-union check-live-values ;
: begin-block ( bb -- ) : begin-block ( bb -- )
dup block-from 1 - prepare-insn dup basic-block set
[ block-from compute-live-values ] keep register-live-ins get set-at ; dup block-from prepare-insn
[ [ live-in ] [ block-from ] bi compute-live-values ] keep
register-live-ins get set-at ;
: end-block ( bb -- ) : end-block ( bb -- )
[ block-to compute-live-values ] keep register-live-outs get set-at ; [ [ live-out ] [ block-to ] bi compute-live-values ] keep
register-live-outs get set-at ;
ERROR: bad-vreg vreg ; ERROR: bad-vreg vreg ;
@ -190,10 +178,12 @@ ERROR: bad-vreg vreg ;
[ [
bb begin-block bb begin-block
[ [
[ insn#>> prepare-insn ] {
[ assign-registers-in-insn ] [ insn#>> 1 - prepare-insn ]
[ , ] [ insn#>> prepare-insn ]
tri [ assign-registers-in-insn ]
[ , ]
} cleave
] each ] each
bb end-block bb end-block
] V{ } make ] V{ } make

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences sets arrays math strings fry USING: accessors kernel sequences sets arrays math strings fry
namespaces prettyprint compiler.cfg.linear-scan.live-intervals namespaces prettyprint compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg ; compiler.cfg.linear-scan.allocation compiler.cfg assocs ;
IN: compiler.cfg.linear-scan.debugger IN: compiler.cfg.linear-scan.debugger
: check-assigned ( live-intervals -- ) : check-assigned ( live-intervals -- )
@ -19,7 +19,10 @@ IN: compiler.cfg.linear-scan.debugger
] [ 1array ] if ; ] [ 1array ] if ;
: check-linear-scan ( live-intervals machine-registers -- ) : check-linear-scan ( live-intervals machine-registers -- )
[ [ clone ] map ] dip allocate-registers [
[ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc
live-intervals set
] dip allocate-registers
[ split-children ] map concat check-assigned ; [ split-children ] map concat check-assigned ;
: picture ( uses -- str ) : picture ( uses -- str )

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

@ -1,7 +1,7 @@
IN: compiler.cfg.linear-scan.tests IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors locals kernel fry arrays splitting namespaces math accessors vectors locals
math.order grouping math.order grouping strings strings.private
cpu.architecture cpu.architecture
compiler.cfg compiler.cfg
compiler.cfg.optimizer compiler.cfg.optimizer
@ -13,6 +13,7 @@ compiler.cfg.rpo
compiler.cfg.linearization compiler.cfg.linearization
compiler.cfg.debugger compiler.cfg.debugger
compiler.cfg.linear-scan compiler.cfg.linear-scan
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.allocation.state
@ -24,6 +25,7 @@ FROM: compiler.cfg.linear-scan.assignment => check-assignment? ;
check-allocation? on check-allocation? on
check-assignment? on check-assignment? on
check-numbering? on
[ [
{ T{ live-range f 1 10 } T{ live-range f 15 15 } } { T{ live-range f 1 10 } T{ live-range f 15 15 } }
@ -76,36 +78,6 @@ check-assignment? on
{ T{ live-range f 0 5 } } 0 split-ranges { T{ live-range f 0 5 } } 0 split-ranges
] unit-test ] unit-test
[ 7 ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 3 7 10 } }
}
4 [ >= ] find-use
] unit-test
[ 4 ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 3 4 10 } }
}
4 [ >= ] find-use
] unit-test
[ f ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 3 4 10 } }
}
100 [ >= ] find-use
] unit-test
[ [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
@ -209,86 +181,130 @@ check-assignment? on
[ [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 3 } { start 0 }
{ end 4 }
{ uses V{ 0 1 4 } }
{ ranges V{ T{ live-range f 0 4 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 10 } { end 10 }
{ uses V{ 3 10 } } { uses V{ 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } }
} }
] [ ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 10 } }
{ ranges V{ T{ live-range f 0 10 } } }
} 5 split-before-use [ f >>split-next ] bi@
] unit-test
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 4 }
{ uses V{ 0 1 4 } }
{ ranges V{ T{ live-range f 0 4 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 10 }
{ uses V{ 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } }
}
] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 4 5 10 } }
{ ranges V{ T{ live-range f 0 10 } } }
} 5 split-before-use [ f >>split-next ] bi@
] unit-test
[
{ {
T{ live-interval 3
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } 10
{ start 1 }
{ end 15 }
{ uses V{ 1 3 7 10 15 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 3 }
{ end 8 }
{ uses V{ 3 4 8 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 3 }
{ end 10 }
{ uses V{ 3 10 } }
}
} }
] [
H{
{ int-regs
V{
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ reg 1 }
{ start 1 }
{ end 15 }
{ uses V{ 1 3 7 10 15 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ reg 2 }
{ start 3 }
{ end 8 }
{ uses V{ 3 4 8 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ reg 3 }
{ start 3 }
{ end 10 }
{ uses V{ 3 10 } }
}
}
}
} active-intervals set
H{ } inactive-intervals set
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 } { start 5 }
{ end 5 } { end 5 }
{ uses V{ 5 } } { uses V{ 5 } }
} }
interval-to-spill spill-status
] unit-test ] unit-test
[ t ] [ [
T{ live-interval {
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } 1
{ start 5 } 1/0.
{ end 15 }
{ uses V{ 5 10 15 } }
} }
] [
H{
{ int-regs
V{
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ reg 1 }
{ start 1 }
{ end 15 }
{ uses V{ 1 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ reg 2 }
{ start 3 }
{ end 8 }
{ uses V{ 3 8 } }
}
}
}
} active-intervals set
H{ } inactive-intervals set
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 1 }
{ end 20 }
{ uses V{ 1 20 } }
}
spill-existing?
] unit-test
[ f ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 15 }
{ uses V{ 5 10 15 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 20 }
{ uses V{ 1 7 20 } }
}
spill-existing?
] unit-test
[ t ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 } { start 5 }
{ end 5 } { end 5 }
{ uses V{ 5 } } { uses V{ 5 } }
} }
T{ live-interval spill-status
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 20 }
{ uses V{ 1 7 20 } }
}
spill-existing?
] unit-test ] unit-test
[ ] [ [ ] [
@ -1427,6 +1443,20 @@ USING: math.private ;
intersect-live-ranges intersect-live-ranges
] unit-test ] unit-test
[ f ] [
{
T{ live-range f 0 10 }
T{ live-range f 20 30 }
T{ live-range f 40 50 }
}
{
T{ live-range f 11 15 }
T{ live-range f 31 36 }
T{ live-range f 51 55 }
}
intersect-live-ranges
] unit-test
[ 5 ] [ [ 5 ] [
T{ live-interval T{ live-interval
{ start 0 } { start 0 }
@ -1555,12 +1585,14 @@ V{
SYMBOL: linear-scan-result SYMBOL: linear-scan-result
:: test-linear-scan-on-cfg ( regs -- ) :: test-linear-scan-on-cfg ( regs -- )
cfg new 0 get >>entry [
compute-predecessors cfg new 0 get >>entry
compute-liveness compute-predecessors
dup reverse-post-order compute-liveness
{ { int-regs regs } } (linear-scan) dup reverse-post-order
flatten-cfg 1array mr. ; { { int-regs regs } } (linear-scan)
flatten-cfg 1array mr.
] with-scope ;
! This test has a critical edge -- do we care about these? ! This test has a critical edge -- do we care about these?
@ -1858,6 +1890,8 @@ test-diamond
[ _spill ] [ 3 get instructions>> second class ] unit-test [ _spill ] [ 3 get instructions>> second class ] unit-test
[ f ] [ 3 get instructions>> [ _reload? ] any? ] unit-test
[ _reload ] [ 4 get instructions>> first class ] unit-test [ _reload ] [ 4 get instructions>> first class ] unit-test
! Resolve pass ! Resolve pass
@ -1976,3 +2010,528 @@ V{
! Resolve pass should insert this ! Resolve pass should insert this
[ _reload ] [ 5 get instructions>> first class ] unit-test [ _reload ] [ 5 get instructions>> first class ] unit-test
! Some random bug
V{
T{ ##peek f V int-regs 1 D 1 }
T{ ##peek f V int-regs 2 D 2 }
T{ ##replace f V int-regs 1 D 1 }
T{ ##replace f V int-regs 2 D 2 }
T{ ##peek f V int-regs 3 D 0 }
T{ ##peek f V int-regs 0 D 0 }
T{ ##branch }
} 0 test-bb
V{ T{ ##branch } } 1 test-bb
V{
T{ ##peek f V int-regs 1 D 1 }
T{ ##peek f V int-regs 2 D 2 }
T{ ##replace f V int-regs 3 D 3 }
T{ ##replace f V int-regs 1 D 1 }
T{ ##replace f V int-regs 2 D 2 }
T{ ##replace f V int-regs 0 D 3 }
T{ ##branch }
} 2 test-bb
V{ T{ ##branch } } 3 test-bb
V{
T{ ##return }
} 4 test-bb
test-diamond
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
! Spilling an interval immediately after its activated;
! and the interval does not have a use at the activation point
V{
T{ ##peek f V int-regs 1 D 1 }
T{ ##peek f V int-regs 2 D 2 }
T{ ##replace f V int-regs 1 D 1 }
T{ ##replace f V int-regs 2 D 2 }
T{ ##peek f V int-regs 0 D 0 }
T{ ##branch }
} 0 test-bb
V{ T{ ##branch } } 1 test-bb
V{
T{ ##peek f V int-regs 1 D 1 }
T{ ##branch }
} 2 test-bb
V{
T{ ##replace f V int-regs 1 D 1 }
T{ ##peek f V int-regs 2 D 2 }
T{ ##replace f V int-regs 2 D 2 }
T{ ##branch }
} 3 test-bb
V{ T{ ##branch } } 4 test-bb
V{
T{ ##replace f V int-regs 0 D 0 }
T{ ##return }
} 5 test-bb
1 get 1vector 0 get (>>successors)
2 get 4 get V{ } 2sequence 1 get (>>successors)
5 get 1vector 4 get (>>successors)
3 get 1vector 2 get (>>successors)
5 get 1vector 3 get (>>successors)
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
! Reduction of push-all regression, x86-32
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
T{ ##load-immediate { dst V int-regs 61 } }
T{ ##peek { dst V int-regs 62 } { loc D 0 } }
T{ ##peek { dst V int-regs 64 } { loc D 1 } }
T{ ##slot-imm
{ dst V int-regs 69 }
{ obj V int-regs 64 }
{ slot 1 }
{ tag 2 }
}
T{ ##copy { dst V int-regs 79 } { src V int-regs 69 } }
T{ ##slot-imm
{ dst V int-regs 85 }
{ obj V int-regs 62 }
{ slot 2 }
{ tag 7 }
}
T{ ##compare-branch
{ src1 V int-regs 69 }
{ src2 V int-regs 85 }
{ cc cc> }
}
} 1 test-bb
V{
T{ ##slot-imm
{ dst V int-regs 97 }
{ obj V int-regs 62 }
{ slot 2 }
{ tag 7 }
}
T{ ##replace { src V int-regs 79 } { loc D 3 } }
T{ ##replace { src V int-regs 62 } { loc D 4 } }
T{ ##replace { src V int-regs 79 } { loc D 1 } }
T{ ##replace { src V int-regs 62 } { loc D 2 } }
T{ ##replace { src V int-regs 61 } { loc D 5 } }
T{ ##replace { src V int-regs 62 } { loc R 0 } }
T{ ##replace { src V int-regs 69 } { loc R 1 } }
T{ ##replace { src V int-regs 97 } { loc D 0 } }
T{ ##call { word resize-array } }
T{ ##branch }
} 2 test-bb
V{
T{ ##peek { dst V int-regs 98 } { loc R 0 } }
T{ ##peek { dst V int-regs 100 } { loc D 0 } }
T{ ##set-slot-imm
{ src V int-regs 100 }
{ obj V int-regs 98 }
{ slot 2 }
{ tag 7 }
}
T{ ##peek { dst V int-regs 108 } { loc D 2 } }
T{ ##peek { dst V int-regs 110 } { loc D 3 } }
T{ ##peek { dst V int-regs 112 } { loc D 0 } }
T{ ##peek { dst V int-regs 114 } { loc D 1 } }
T{ ##peek { dst V int-regs 116 } { loc D 4 } }
T{ ##peek { dst V int-regs 119 } { loc R 0 } }
T{ ##copy { dst V int-regs 109 } { src V int-regs 108 } }
T{ ##copy { dst V int-regs 111 } { src V int-regs 110 } }
T{ ##copy { dst V int-regs 113 } { src V int-regs 112 } }
T{ ##copy { dst V int-regs 115 } { src V int-regs 114 } }
T{ ##copy { dst V int-regs 117 } { src V int-regs 116 } }
T{ ##copy { dst V int-regs 120 } { src V int-regs 119 } }
T{ ##branch }
} 3 test-bb
V{
T{ ##copy { dst V int-regs 109 } { src V int-regs 62 } }
T{ ##copy { dst V int-regs 111 } { src V int-regs 61 } }
T{ ##copy { dst V int-regs 113 } { src V int-regs 62 } }
T{ ##copy { dst V int-regs 115 } { src V int-regs 79 } }
T{ ##copy { dst V int-regs 117 } { src V int-regs 64 } }
T{ ##copy { dst V int-regs 120 } { src V int-regs 69 } }
T{ ##branch }
} 4 test-bb
V{
T{ ##replace { src V int-regs 120 } { loc D 0 } }
T{ ##replace { src V int-regs 109 } { loc D 3 } }
T{ ##replace { src V int-regs 111 } { loc D 4 } }
T{ ##replace { src V int-regs 113 } { loc D 1 } }
T{ ##replace { src V int-regs 115 } { loc D 2 } }
T{ ##replace { src V int-regs 117 } { loc D 5 } }
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
3 get 5 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
! Another reduction of push-all
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
T{ ##peek { dst V int-regs 85 } { loc D 0 } }
T{ ##slot-imm
{ dst V int-regs 89 }
{ obj V int-regs 85 }
{ slot 3 }
{ tag 7 }
}
T{ ##peek { dst V int-regs 91 } { loc D 1 } }
T{ ##slot-imm
{ dst V int-regs 96 }
{ obj V int-regs 91 }
{ slot 1 }
{ tag 2 }
}
T{ ##add
{ dst V int-regs 109 }
{ src1 V int-regs 89 }
{ src2 V int-regs 96 }
}
T{ ##slot-imm
{ dst V int-regs 115 }
{ obj V int-regs 85 }
{ slot 2 }
{ tag 7 }
}
T{ ##slot-imm
{ dst V int-regs 118 }
{ obj V int-regs 115 }
{ slot 1 }
{ tag 2 }
}
T{ ##compare-branch
{ src1 V int-regs 109 }
{ src2 V int-regs 118 }
{ cc cc> }
}
} 1 test-bb
V{
T{ ##add-imm
{ dst V int-regs 128 }
{ src1 V int-regs 109 }
{ src2 8 }
}
T{ ##load-immediate { dst V int-regs 129 } { val 24 } }
T{ ##inc-d { n 4 } }
T{ ##inc-r { n 1 } }
T{ ##replace { src V int-regs 109 } { loc D 2 } }
T{ ##replace { src V int-regs 85 } { loc D 3 } }
T{ ##replace { src V int-regs 128 } { loc D 0 } }
T{ ##replace { src V int-regs 85 } { loc D 1 } }
T{ ##replace { src V int-regs 89 } { loc D 4 } }
T{ ##replace { src V int-regs 96 } { loc R 0 } }
T{ ##fixnum-mul
{ src1 V int-regs 128 }
{ src2 V int-regs 129 }
{ temp1 V int-regs 132 }
{ temp2 V int-regs 133 }
}
T{ ##branch }
} 2 test-bb
V{
T{ ##peek { dst V int-regs 134 } { loc D 1 } }
T{ ##slot-imm
{ dst V int-regs 140 }
{ obj V int-regs 134 }
{ slot 2 }
{ tag 7 }
}
T{ ##inc-d { n 1 } }
T{ ##inc-r { n 1 } }
T{ ##replace { src V int-regs 140 } { loc D 0 } }
T{ ##replace { src V int-regs 134 } { loc R 0 } }
T{ ##call { word resize-array } }
T{ ##branch }
} 3 test-bb
V{
T{ ##peek { dst V int-regs 141 } { loc R 0 } }
T{ ##peek { dst V int-regs 143 } { loc D 0 } }
T{ ##set-slot-imm
{ src V int-regs 143 }
{ obj V int-regs 141 }
{ slot 2 }
{ tag 7 }
}
T{ ##write-barrier
{ src V int-regs 141 }
{ card# V int-regs 145 }
{ table V int-regs 146 }
}
T{ ##inc-d { n -1 } }
T{ ##inc-r { n -1 } }
T{ ##peek { dst V int-regs 156 } { loc D 2 } }
T{ ##peek { dst V int-regs 158 } { loc D 3 } }
T{ ##peek { dst V int-regs 160 } { loc D 0 } }
T{ ##peek { dst V int-regs 162 } { loc D 1 } }
T{ ##peek { dst V int-regs 164 } { loc D 4 } }
T{ ##peek { dst V int-regs 167 } { loc R 0 } }
T{ ##copy { dst V int-regs 157 } { src V int-regs 156 } }
T{ ##copy { dst V int-regs 159 } { src V int-regs 158 } }
T{ ##copy { dst V int-regs 161 } { src V int-regs 160 } }
T{ ##copy { dst V int-regs 163 } { src V int-regs 162 } }
T{ ##copy { dst V int-regs 165 } { src V int-regs 164 } }
T{ ##copy { dst V int-regs 168 } { src V int-regs 167 } }
T{ ##branch }
} 4 test-bb
V{
T{ ##inc-d { n 3 } }
T{ ##inc-r { n 1 } }
T{ ##copy { dst V int-regs 157 } { src V int-regs 85 } }
T{ ##copy { dst V int-regs 159 } { src V int-regs 89 } }
T{ ##copy { dst V int-regs 161 } { src V int-regs 85 } }
T{ ##copy { dst V int-regs 163 } { src V int-regs 109 } }
T{ ##copy { dst V int-regs 165 } { src V int-regs 91 } }
T{ ##copy { dst V int-regs 168 } { src V int-regs 96 } }
T{ ##branch }
} 5 test-bb
V{
T{ ##set-slot-imm
{ src V int-regs 163 }
{ obj V int-regs 161 }
{ slot 3 }
{ tag 7 }
}
T{ ##inc-d { n 1 } }
T{ ##inc-r { n -1 } }
T{ ##replace { src V int-regs 168 } { loc D 0 } }
T{ ##replace { src V int-regs 157 } { loc D 3 } }
T{ ##replace { src V int-regs 159 } { loc D 4 } }
T{ ##replace { src V int-regs 161 } { loc D 1 } }
T{ ##replace { src V int-regs 163 } { loc D 2 } }
T{ ##replace { src V int-regs 165 } { loc D 5 } }
T{ ##epilogue }
T{ ##return }
} 6 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 5 get V{ } 2sequence >>successors drop
2 get 3 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
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
! Another push-all reduction to demonstrate numbering anamoly
V{ T{ ##prologue } T{ ##branch } }
0 test-bb
V{
T{ ##peek { dst V int-regs 1 } { loc D 0 } }
T{ ##slot-imm
{ dst V int-regs 5 }
{ obj V int-regs 1 }
{ slot 3 }
{ tag 7 }
}
T{ ##peek { dst V int-regs 7 } { loc D 1 } }
T{ ##slot-imm
{ dst V int-regs 12 }
{ obj V int-regs 7 }
{ slot 1 }
{ tag 6 }
}
T{ ##add
{ dst V int-regs 25 }
{ src1 V int-regs 5 }
{ src2 V int-regs 12 }
}
T{ ##compare-branch
{ src1 V int-regs 25 }
{ src2 V int-regs 5 }
{ cc cc> }
}
}
1 test-bb
V{
T{ ##slot-imm
{ dst V int-regs 41 }
{ obj V int-regs 1 }
{ slot 2 }
{ tag 7 }
}
T{ ##slot-imm
{ dst V int-regs 44 }
{ obj V int-regs 41 }
{ slot 1 }
{ tag 6 }
}
T{ ##compare-branch
{ src1 V int-regs 25 }
{ src2 V int-regs 44 }
{ cc cc> }
}
}
2 test-bb
V{
T{ ##add-imm
{ dst V int-regs 54 }
{ src1 V int-regs 25 }
{ src2 8 }
}
T{ ##load-immediate { dst V int-regs 55 } { val 24 } }
T{ ##inc-d { n 4 } }
T{ ##inc-r { n 1 } }
T{ ##replace { src V int-regs 25 } { loc D 2 } }
T{ ##replace { src V int-regs 1 } { loc D 3 } }
T{ ##replace { src V int-regs 5 } { loc D 4 } }
T{ ##replace { src V int-regs 1 } { loc D 1 } }
T{ ##replace { src V int-regs 54 } { loc D 0 } }
T{ ##replace { src V int-regs 12 } { loc R 0 } }
T{ ##fixnum-mul
{ src1 V int-regs 54 }
{ src2 V int-regs 55 }
{ temp1 V int-regs 58 }
{ temp2 V int-regs 59 }
}
T{ ##branch }
}
3 test-bb
V{
T{ ##peek { dst V int-regs 60 } { loc D 1 } }
T{ ##slot-imm
{ dst V int-regs 66 }
{ obj V int-regs 60 }
{ slot 2 }
{ tag 7 }
}
T{ ##inc-d { n 1 } }
T{ ##inc-r { n 1 } }
T{ ##replace { src V int-regs 66 } { loc D 0 } }
T{ ##replace { src V int-regs 60 } { loc R 0 } }
T{ ##call { word resize-string } }
T{ ##branch }
}
4 test-bb
V{
T{ ##peek { dst V int-regs 67 } { loc R 0 } }
T{ ##peek { dst V int-regs 68 } { loc D 0 } }
T{ ##set-slot-imm
{ src V int-regs 68 }
{ obj V int-regs 67 }
{ slot 2 }
{ tag 7 }
}
T{ ##write-barrier
{ src V int-regs 67 }
{ card# V int-regs 75 }
{ table V int-regs 76 }
}
T{ ##inc-d { n -1 } }
T{ ##inc-r { n -1 } }
T{ ##peek { dst V int-regs 94 } { loc D 0 } }
T{ ##peek { dst V int-regs 96 } { loc D 1 } }
T{ ##peek { dst V int-regs 98 } { loc D 2 } }
T{ ##peek { dst V int-regs 100 } { loc D 3 } }
T{ ##peek { dst V int-regs 102 } { loc D 4 } }
T{ ##peek { dst V int-regs 106 } { loc R 0 } }
T{ ##copy { dst V int-regs 95 } { src V int-regs 94 } }
T{ ##copy { dst V int-regs 97 } { src V int-regs 96 } }
T{ ##copy { dst V int-regs 99 } { src V int-regs 98 } }
T{ ##copy { dst V int-regs 101 } { src V int-regs 100 } }
T{ ##copy { dst V int-regs 103 } { src V int-regs 102 } }
T{ ##copy { dst V int-regs 107 } { src V int-regs 106 } }
T{ ##branch }
}
5 test-bb
V{
T{ ##inc-d { n 3 } }
T{ ##inc-r { n 1 } }
T{ ##copy { dst V int-regs 95 } { src V int-regs 1 } }
T{ ##copy { dst V int-regs 97 } { src V int-regs 25 } }
T{ ##copy { dst V int-regs 99 } { src V int-regs 1 } }
T{ ##copy { dst V int-regs 101 } { src V int-regs 5 } }
T{ ##copy { dst V int-regs 103 } { src V int-regs 7 } }
T{ ##copy { dst V int-regs 107 } { src V int-regs 12 } }
T{ ##branch }
}
6 test-bb
V{
T{ ##load-immediate
{ dst V int-regs 78 }
{ val 4611686018427387896 }
}
T{ ##and
{ dst V int-regs 81 }
{ src1 V int-regs 97 }
{ src2 V int-regs 78 }
}
T{ ##set-slot-imm
{ src V int-regs 81 }
{ obj V int-regs 95 }
{ slot 3 }
{ tag 7 }
}
T{ ##inc-d { n -2 } }
T{ ##copy { dst V int-regs 110 } { src V int-regs 99 } }
T{ ##copy { dst V int-regs 111 } { src V int-regs 101 } }
T{ ##copy { dst V int-regs 112 } { src V int-regs 103 } }
T{ ##copy { dst V int-regs 117 } { src V int-regs 107 } }
T{ ##branch }
}
7 test-bb
V{
T{ ##inc-d { n 1 } }
T{ ##inc-r { n 1 } }
T{ ##copy { dst V int-regs 110 } { src V int-regs 1 } }
T{ ##copy { dst V int-regs 111 } { src V int-regs 5 } }
T{ ##copy { dst V int-regs 112 } { src V int-regs 7 } }
T{ ##copy { dst V int-regs 117 } { src V int-regs 12 } }
T{ ##branch }
}
8 test-bb
V{
T{ ##inc-d { n 1 } }
T{ ##inc-r { n -1 } }
T{ ##replace { src V int-regs 117 } { loc D 0 } }
T{ ##replace { src V int-regs 110 } { loc D 1 } }
T{ ##replace { src V int-regs 111 } { loc D 2 } }
T{ ##replace { src V int-regs 112 } { loc D 3 } }
T{ ##epilogue }
T{ ##return }
}
9 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 8 get V{ } 2sequence >>successors drop
2 get 3 get 6 get V{ } 2sequence >>successors drop
3 get 4 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
5 get 7 get 1vector >>successors drop
6 get 7 get 1vector >>successors drop
7 get 9 get 1vector >>successors drop
8 get 9 get 1vector >>successors drop
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test

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

@ -31,7 +31,8 @@ IN: compiler.cfg.linear-scan
rpo number-instructions rpo number-instructions
rpo compute-live-intervals machine-registers allocate-registers rpo compute-live-intervals machine-registers allocate-registers
rpo assign-registers rpo assign-registers
rpo resolve-data-flow ; rpo resolve-data-flow
rpo check-numbering ;
: linear-scan ( cfg -- cfg' ) : linear-scan ( cfg -- cfg' )
[ [

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

@ -57,7 +57,7 @@ ERROR: dead-value-error vreg ;
V{ } clone >>ranges V{ } clone >>ranges
swap >>vreg ; swap >>vreg ;
: block-from ( bb -- n ) instructions>> first insn#>> ; : block-from ( bb -- n ) instructions>> first insn#>> 1 - ;
: block-to ( bb -- n ) instructions>> last insn#>> ; : block-to ( bb -- n ) instructions>> last insn#>> ;
@ -145,8 +145,7 @@ M: ##copy-float compute-live-intervals*
<reversed> [ compute-live-intervals-step ] each <reversed> [ compute-live-intervals-step ] each
] keep values dup finish-live-intervals ; ] keep values dup finish-live-intervals ;
: relevant-ranges ( new inactive -- new' inactive' ) : relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )
! Slice off all ranges of 'inactive' that precede the start of 'new'
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ; [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
: intersect-live-range ( range1 range2 -- n/f ) : intersect-live-range ( range1 range2 -- n/f )
@ -155,8 +154,8 @@ M: ##copy-float compute-live-intervals*
: intersect-live-ranges ( ranges1 ranges2 -- n ) : intersect-live-ranges ( ranges1 ranges2 -- n )
{ {
{ [ over empty? ] [ 2drop 1/0. ] } { [ over empty? ] [ 2drop f ] }
{ [ dup empty? ] [ 2drop 1/0. ] } { [ dup empty? ] [ 2drop f ] }
[ [
2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [ 2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
drop drop
@ -166,3 +165,6 @@ M: ##copy-float compute-live-intervals*
] if ] if
] ]
} cond ; } cond ;
: intervals-intersect? ( interval1 interval2 -- ? )
relevant-ranges intersect-live-ranges >boolean ; inline

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

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

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

@ -3,6 +3,7 @@ compiler.cfg.debugger compiler.cfg.instructions
compiler.cfg.linear-scan.debugger compiler.cfg.linear-scan.debugger
compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.numbering compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.resolve compiler.cfg.predecessors compiler.cfg.linear-scan.resolve compiler.cfg.predecessors
compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel
namespaces tools.test vectors ; namespaces tools.test vectors ;
@ -12,15 +13,18 @@ IN: compiler.cfg.linear-scan.resolve.tests
{ 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array { 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
] unit-test ] unit-test
H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
H{ } clone spill-temps set
[ [
{ {
T{ _copy { dst 5 } { src 4 } { class int-regs } } T{ _copy { dst 5 } { src 4 } { class int-regs } }
T{ _spill { src 1 } { class int-regs } { n spill-temp } } T{ _spill { src 1 } { class int-regs } { n 10 } }
T{ _copy { dst 1 } { src 0 } { class int-regs } } T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _reload { dst 0 } { class int-regs } { n spill-temp } } T{ _reload { dst 0 } { class int-regs } { n 10 } }
T{ _spill { src 1 } { class float-regs } { n spill-temp } } T{ _spill { src 1 } { class float-regs } { n 20 } }
T{ _copy { dst 1 } { src 0 } { class float-regs } } T{ _copy { dst 1 } { src 0 } { class float-regs } }
T{ _reload { dst 0 } { class float-regs } { n spill-temp } } T{ _reload { dst 0 } { class float-regs } { n 20 } }
} }
] [ ] [
{ {
@ -34,10 +38,10 @@ IN: compiler.cfg.linear-scan.resolve.tests
[ [
{ {
T{ _spill { src 2 } { class int-regs } { n spill-temp } } T{ _spill { src 2 } { class int-regs } { n 10 } }
T{ _copy { dst 2 } { src 1 } { class int-regs } } T{ _copy { dst 2 } { src 1 } { class int-regs } }
T{ _copy { dst 1 } { src 0 } { class int-regs } } T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _reload { dst 0 } { class int-regs } { n spill-temp } } T{ _reload { dst 0 } { class int-regs } { n 10 } }
} }
] [ ] [
{ {
@ -49,10 +53,10 @@ IN: compiler.cfg.linear-scan.resolve.tests
[ [
{ {
T{ _spill { src 0 } { class int-regs } { n spill-temp } } T{ _spill { src 0 } { class int-regs } { n 10 } }
T{ _copy { dst 0 } { src 2 } { class int-regs } } T{ _copy { dst 0 } { src 2 } { class int-regs } }
T{ _copy { dst 2 } { src 1 } { class int-regs } } T{ _copy { dst 2 } { src 1 } { class int-regs } }
T{ _reload { dst 1 } { class int-regs } { n spill-temp } } T{ _reload { dst 1 } { class int-regs } { n 10 } }
} }
] [ ] [
{ {
@ -113,10 +117,10 @@ IN: compiler.cfg.linear-scan.resolve.tests
{ {
T{ _copy { dst 1 } { src 0 } { class int-regs } } T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _copy { dst 2 } { 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{ _spill { src 4 } { class int-regs } { n 10 } }
T{ _copy { dst 4 } { src 0 } { class int-regs } } T{ _copy { dst 4 } { src 0 } { class int-regs } }
T{ _copy { dst 0 } { src 3 } { class int-regs } } T{ _copy { dst 0 } { src 3 } { class int-regs } }
T{ _reload { dst 3 } { class int-regs } { n spill-temp } } T{ _reload { dst 3 } { class int-regs } { n 10 } }
} }
] [ ] [
{ {
@ -133,10 +137,10 @@ IN: compiler.cfg.linear-scan.resolve.tests
T{ _copy { dst 2 } { src 0 } { class int-regs } } T{ _copy { dst 2 } { src 0 } { class int-regs } }
T{ _copy { dst 9 } { src 1 } { class int-regs } } T{ _copy { dst 9 } { src 1 } { class int-regs } }
T{ _copy { dst 1 } { src 0 } { class int-regs } } T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _spill { src 4 } { class int-regs } { n spill-temp } } T{ _spill { src 4 } { class int-regs } { n 10 } }
T{ _copy { dst 4 } { src 0 } { class int-regs } } T{ _copy { dst 4 } { src 0 } { class int-regs } }
T{ _copy { dst 0 } { src 3 } { class int-regs } } T{ _copy { dst 0 } { src 3 } { class int-regs } }
T{ _reload { dst 3 } { class int-regs } { n spill-temp } } T{ _reload { dst 3 } { class int-regs } { n 10 } }
} }
] [ ] [
{ {

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

@ -3,10 +3,15 @@
USING: accessors arrays assocs classes.parser classes.tuple USING: accessors arrays assocs classes.parser classes.tuple
combinators combinators.short-circuit fry hashtables kernel locals combinators combinators.short-circuit fry hashtables kernel locals
make math math.order namespaces sequences sets words parser make math math.order namespaces sequences sets words parser
compiler.cfg.instructions compiler.cfg.linear-scan.assignment compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state
compiler.cfg.liveness ; compiler.cfg.linear-scan.assignment compiler.cfg.liveness ;
IN: compiler.cfg.linear-scan.resolve IN: compiler.cfg.linear-scan.resolve
SYMBOL: spill-temps
: spill-temp ( reg-class -- n )
spill-temps get [ next-spill-slot ] cache ;
<< <<
TUPLE: operation from to reg-class ; TUPLE: operation from to reg-class ;
@ -116,11 +121,15 @@ ERROR: resolve-error ;
: break-cycle-n ( operations -- operations' ) : break-cycle-n ( operations -- operations' )
split-cycle [ split-cycle [
[ from>> spill-temp <spill-slot> ] [ from>> ]
[ reg-class>> ] bi \ register->memory boa [ reg-class>> spill-temp <spill-slot> ]
[ reg-class>> ]
tri \ register->memory boa
] [ ] [
[ to>> spill-temp <spill-slot> swap ] [ reg-class>> spill-temp <spill-slot> ]
[ reg-class>> ] bi \ memory->register boa [ to>> ]
[ reg-class>> ]
tri \ memory->register boa
] bi [ 1array ] bi@ surround ; ] bi [ 1array ] bi@ surround ;
: break-cycle ( operations -- operations' ) : break-cycle ( operations -- operations' )
@ -197,4 +206,5 @@ ERROR: resolve-error ;
dup successors>> [ resolve-edge-data-flow ] with each ; dup successors>> [ resolve-edge-data-flow ] with each ;
: resolve-data-flow ( rpo -- ) : resolve-data-flow ( rpo -- )
H{ } clone spill-temps set
[ resolve-block-data-flow ] each ; [ resolve-block-data-flow ] each ;

5
basis/editors/editors.factor
View File

@ -3,8 +3,9 @@
USING: parser lexer kernel namespaces sequences definitions USING: parser lexer kernel namespaces sequences definitions
io.files io.backend io.pathnames io summary continuations io.files io.backend io.pathnames io summary continuations
tools.crossref vocabs.hierarchy prettyprint source-files tools.crossref vocabs.hierarchy prettyprint source-files
source-files.errors assocs vocabs vocabs.loader splitting source-files.errors assocs vocabs.loader splitting
accessors debugger help.topics ; accessors debugger help.topics ;
FROM: vocabs => vocab-name >vocab-link ;
IN: editors IN: editors
TUPLE: no-edit-hook ; TUPLE: no-edit-hook ;
@ -15,7 +16,7 @@ M: no-edit-hook summary
SYMBOL: edit-hook SYMBOL: edit-hook
: available-editors ( -- seq ) : available-editors ( -- seq )
"editors" all-child-vocabs-seq [ vocab-name ] map ; "editors" child-vocabs no-roots no-prefixes [ vocab-name ] map ;
: editor-restarts ( -- alist ) : editor-restarts ( -- alist )
available-editors available-editors

2
basis/functors/functors.factor
View File

@ -121,6 +121,8 @@ PRIVATE>
SYNTAX: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; SYNTAX: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ;
SYNTAX: DEFERS [ current-vocab create ] (INTERPOLATE) ;
SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ; SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;

3
basis/help/apropos/apropos.factor
View File

@ -42,7 +42,8 @@ M: more-completions article-content
[ dup name>> >lower ] { } map>assoc ; [ dup name>> >lower ] { } map>assoc ;
: vocab-candidates ( -- candidates ) : vocab-candidates ( -- candidates )
all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ; all-vocabs-recursive no-roots no-prefixes
[ dup vocab-name >lower ] { } map>assoc ;
: help-candidates ( seq -- candidates ) : help-candidates ( seq -- candidates )
[ [ >link ] [ article-title >lower ] bi ] { } map>assoc [ [ >link ] [ article-title >lower ] bi ] { } map>assoc

8
basis/help/html/html.factor
View File

@ -5,7 +5,8 @@ io.files io.files.temp io.directories html.streams help kernel
assocs sequences make words accessors arrays help.topics vocabs assocs sequences make words accessors arrays help.topics vocabs
vocabs.hierarchy help.vocabs namespaces prettyprint io vocabs.hierarchy help.vocabs namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order vocabs.loader serialize fry memoize unicode.case math.order
sorting debugger html xml.syntax xml.writer math.parser ; sorting debugger html xml.syntax xml.writer math.parser
sets hashtables ;
FROM: io.encodings.ascii => ascii ; FROM: io.encodings.ascii => ascii ;
FROM: ascii => ascii? ; FROM: ascii => ascii? ;
IN: help.html IN: help.html
@ -24,6 +25,7 @@ IN: help.html
{ CHAR: / "__slash__" } { CHAR: / "__slash__" }
{ CHAR: , "__comma__" } { CHAR: , "__comma__" }
{ CHAR: @ "__at__" } { CHAR: @ "__at__" }
{ CHAR: # "__hash__" }
} at [ % ] [ , ] ?if } at [ % ] [ , ] ?if
] [ number>string "__" "__" surround % ] if ; ] [ number>string "__" "__" surround % ] if ;
@ -71,9 +73,7 @@ M: topic url-of topic>filename ;
dup topic>filename utf8 [ help>html write-xml ] with-file-writer ; dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
: all-vocabs-really ( -- seq ) : all-vocabs-really ( -- seq )
#! Hack. all-vocabs >hashtable f over delete-at no-roots remove-redundant-prefixes ;
all-vocabs values concat
vocabs [ find-vocab-root not ] filter [ vocab ] map append ;
: all-topics ( -- topics ) : all-topics ( -- topics )
[ [

3
basis/help/lint/lint.factor
View File

@ -5,6 +5,7 @@ help.topics io kernel namespaces parser sequences
source-files.errors vocabs.hierarchy vocabs words classes source-files.errors vocabs.hierarchy vocabs words classes
locals tools.errors listener ; locals tools.errors listener ;
FROM: help.lint.checks => all-vocabs ; FROM: help.lint.checks => all-vocabs ;
FROM: vocabs => child-vocabs ;
IN: help.lint IN: help.lint
SYMBOL: lint-failures SYMBOL: lint-failures
@ -79,7 +80,7 @@ PRIVATE>
: help-lint ( prefix -- ) : help-lint ( prefix -- )
[ [
auto-use? off auto-use? off
all-vocabs-seq [ vocab-name ] map all-vocabs set all-vocab-names all-vocabs set
group-articles vocab-articles set group-articles vocab-articles set
child-vocabs child-vocabs
[ check-vocab ] each [ check-vocab ] each

6
basis/help/vocabs/vocabs.factor
View File

@ -8,6 +8,7 @@ help.topics io io.files io.pathnames io.styles kernel macros
make namespaces prettyprint sequences sets sorting summary make namespaces prettyprint sequences sets sorting summary
vocabs vocabs.files vocabs.hierarchy vocabs.loader vocabs vocabs.files vocabs.hierarchy vocabs.loader
vocabs.metadata words words.symbol definitions.icons ; vocabs.metadata words words.symbol definitions.icons ;
FROM: vocabs.hierarchy => child-vocabs ;
IN: help.vocabs IN: help.vocabs
: about ( vocab -- ) : about ( vocab -- )
@ -35,7 +36,7 @@ IN: help.vocabs
$heading ; $heading ;
: $vocabs ( seq -- ) : $vocabs ( seq -- )
[ vocab-row ] map vocab-headings prefix $table ; convert-prefixes [ vocab-row ] map vocab-headings prefix $table ;
: $vocab-roots ( assoc -- ) : $vocab-roots ( assoc -- )
[ [
@ -67,7 +68,8 @@ C: <vocab-author> vocab-author
] unless-empty ; ] unless-empty ;
: describe-children ( vocab -- ) : describe-children ( vocab -- )
vocab-name all-child-vocabs $vocab-roots ; vocab-name child-vocabs
$vocab-roots ;
: files. ( seq -- ) : files. ( seq -- )
snippet-style get [ snippet-style get [

2
basis/present/present-tests.factor
View File

@ -5,4 +5,4 @@ USING: tools.test vocabs.hierarchy present math vocabs sequences kernel ;
[ "Hi" ] [ "Hi" present ] unit-test [ "Hi" ] [ "Hi" present ] unit-test
[ "+" ] [ \ + present ] unit-test [ "+" ] [ \ + present ] unit-test
[ "kernel" ] [ "kernel" vocab present ] unit-test [ "kernel" ] [ "kernel" vocab present ] unit-test
[ ] [ all-vocabs-seq [ present ] map drop ] unit-test [ ] [ all-vocabs-recursive no-roots no-prefixes [ present ] map drop ] unit-test

26
basis/specialized-vectors/functor/functor.factor
View File

@ -1,37 +1,25 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private growable USING: functors sequences sequences.private growable
prettyprint.custom kernel words classes math parser ; prettyprint.custom kernel words classes math parser ;
QUALIFIED: vectors.functor
IN: specialized-vectors.functor IN: specialized-vectors.functor
FUNCTOR: define-vector ( T -- ) FUNCTOR: define-vector ( T -- )
V DEFINES-CLASS ${T}-vector
A IS ${T}-array A IS ${T}-array
<A> IS <${A}> <A> IS <${A}>
V DEFINES-CLASS ${T}-vector >V DEFERS >${V}
<V> DEFINES <${V}>
>V DEFINES >${V}
V{ DEFINES ${V}{ V{ DEFINES ${V}{
WHERE WHERE
TUPLE: V { underlying A } { length array-capacity } ; V A <A> vectors.functor:define-vector
: <V> ( capacity -- vector ) <A> 0 V boa ; inline M: V contract 2drop ;
M: V like
drop dup V instance? [
dup A instance? [ dup length V boa ] [ >V ] if
] unless ;
M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
M: A new-resizable drop <V> ;
M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
: >V ( seq -- vector ) V new clone-like ; inline
M: V pprint-delims drop \ V{ \ } ; M: V pprint-delims drop \ V{ \ } ;

2
basis/struct-arrays/struct-arrays-tests.factor
View File

@ -36,3 +36,5 @@ C-STRUCT: test-struct
&free drop &free drop
] with-destructors ] with-destructors
] unit-test ] unit-test
[ 15 ] [ 15 10 "point" <struct-array> resize length ] unit-test

4
basis/struct-arrays/struct-arrays.factor
View File

@ -21,6 +21,10 @@ M: struct-array set-nth-unsafe
M: struct-array new-sequence M: struct-array new-sequence
element-size>> [ * <byte-array> ] 2keep struct-array boa ; inline element-size>> [ * <byte-array> ] 2keep struct-array boa ; inline
M: struct-array resize ( n seq -- newseq )
[ [ element-size>> * ] [ underlying>> ] bi resize ] [ element-size>> ] 2bi
struct-array boa ;
: <struct-array> ( length c-type -- struct-array ) : <struct-array> ( length c-type -- struct-array )
heap-size [ * <byte-array> ] 2keep struct-array boa ; inline heap-size [ * <byte-array> ] 2keep struct-array boa ; inline

16
basis/struct-vectors/struct-vectors-docs.factor Normal file
View File

@ -0,0 +1,16 @@
IN: struct-vectors
USING: help.markup help.syntax alien strings math ;
HELP: struct-vector
{ $class-description "The class of growable C struct and union arrays." } ;
HELP: <struct-vector>
{ $values { "capacity" integer } { "c-type" string } { "struct-vector" struct-vector } }
{ $description "Creates a new vector with the given initial capacity." } ;
ARTICLE: "struct-vectors" "C struct and union vectors"
"The " { $vocab-link "struct-vectors" } " vocabulary implements vectors specialized for holding C struct and union values. These are growable versions of " { $vocab-link "struct-arrays" } "."
{ $subsection struct-vector }
{ $subsection <struct-vector> } ;
ABOUT: "struct-vectors"

20
basis/struct-vectors/struct-vectors-tests.factor Normal file
View File

@ -0,0 +1,20 @@
IN: struct-vectors.tests
USING: struct-vectors tools.test alien.c-types kernel sequences ;
C-STRUCT: point
{ "float" "x" }
{ "float" "y" } ;
: make-point ( x y -- point )
"point" <c-object>
[ set-point-y ] keep
[ set-point-x ] keep ;
[ ] [ 1 "point" <struct-vector> "v" set ] unit-test
[ 1.5 6.0 ] [
1.0 2.0 make-point "v" get push
3.0 4.5 make-point "v" get push
1.5 6.0 make-point "v" get push
"v" get pop [ point-x ] [ point-y ] bi
] unit-test

23
basis/struct-vectors/struct-vectors.factor Normal file
View File

@ -0,0 +1,23 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays growable kernel math sequences
sequences.private struct-arrays ;
IN: struct-vectors
TUPLE: struct-vector
{ underlying struct-array }
{ length array-capacity }
{ c-type read-only } ;
: <struct-vector> ( capacity c-type -- struct-vector )
[ <struct-array> 0 ] keep struct-vector boa ; inline
M: struct-vector new-sequence
[ c-type>> <struct-array> ] [ [ >fixnum ] [ c-type>> ] bi ] 2bi
struct-vector boa ;
M: struct-vector contract 2drop ;
M: struct-array new-resizable c-type>> <struct-vector> ;
INSTANCE: struct-vector growable

10
basis/threads/threads.factor
View File

@ -43,13 +43,15 @@ sleep-entry ;
: thread-registered? ( thread -- ? ) : thread-registered? ( thread -- ? )
id>> threads key? ; id>> threads key? ;
ERROR: already-stopped thread ;
: check-unregistered ( thread -- thread ) : check-unregistered ( thread -- thread )
dup thread-registered? dup thread-registered? [ already-stopped ] when ;
[ "Thread already stopped" throw ] when ;
ERROR: not-running thread ;
: check-registered ( thread -- thread ) : check-registered ( thread -- thread )
dup thread-registered? dup thread-registered? [ not-running ] unless ;
[ "Thread is not running" throw ] unless ;
<PRIVATE <PRIVATE

2
basis/tools/completion/completion.factor
View File

@ -75,7 +75,7 @@ IN: tools.completion
all-words name-completions ; all-words name-completions ;
: vocabs-matching ( str -- seq ) : vocabs-matching ( str -- seq )
all-vocabs-seq name-completions ; all-vocabs-recursive no-roots no-prefixes name-completions ;
: chars-matching ( str -- seq ) : chars-matching ( str -- seq )
name-map keys dup zip completions ; name-map keys dup zip completions ;

7
basis/ui/gadgets/tables/tables.factor
View File

@ -313,13 +313,14 @@ PRIVATE>
if ; if ;
: row-action? ( table -- ? ) : row-action? ( table -- ? )
[ [ mouse-row ] keep valid-line? ] single-click?>> hand-click# get 2 = or ;
[ single-click?>> hand-click# get 2 = or ] bi and ;
<PRIVATE <PRIVATE
: table-button-up ( table -- ) : table-button-up ( table -- )
dup row-action? [ row-action ] [ update-selected-value ] if ; dup [ mouse-row ] keep valid-line? [
dup row-action? [ row-action ] [ update-selected-value ] if
] [ drop ] if ;
PRIVATE> PRIVATE>

1
basis/ui/tools/tools.factor
View File

@ -26,7 +26,6 @@ tool "tool-switching" f {
} define-command-map } define-command-map
tool "common" f { tool "common" f {
{ T{ key-down f { A+ } "s" } save }
{ T{ key-down f { A+ } "w" } close-window } { T{ key-down f { A+ } "w" } close-window }
{ T{ key-down f { A+ } "q" } com-exit } { T{ key-down f { A+ } "q" } com-exit }
{ T{ key-down f f "F2" } refresh-all } { T{ key-down f f "F2" } refresh-all }

33
basis/vectors/functor/functor.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private growable
kernel words classes math parser ;
IN: vectors.functor
FUNCTOR: define-vector ( V A <A> -- )
<V> DEFINES <${V}>
>V DEFINES >${V}
WHERE
TUPLE: V { underlying A } { length array-capacity } ;
: <V> ( capacity -- vector ) <A> 0 V boa ; inline
M: V like
drop dup V instance? [
dup A instance? [ dup length V boa ] [ >V ] if
] unless ;
M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
M: A new-resizable drop <V> ;
M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
: >V ( seq -- vector ) V new clone-like ; inline
INSTANCE: V growable
;FUNCTOR

2
basis/vocabs/cache/cache.factor vendored
View File

@ -7,7 +7,7 @@ IN: vocabs.cache
: reset-cache ( -- ) : reset-cache ( -- )
root-cache get-global clear-assoc root-cache get-global clear-assoc
\ vocab-file-contents reset-memoized \ vocab-file-contents reset-memoized
\ all-vocabs-seq reset-memoized \ all-vocabs-recursive reset-memoized
\ all-authors reset-memoized \ all-authors reset-memoized
\ all-tags reset-memoized ; \ all-tags reset-memoized ;

19
basis/vocabs/hierarchy/hierarchy-docs.factor
View File

@ -7,19 +7,21 @@ $nl
"Loading vocabulary hierarchies:" "Loading vocabulary hierarchies:"
{ $subsection load } { $subsection load }
{ $subsection load-all } { $subsection load-all }
"Getting all vocabularies on disk:" "Getting all vocabularies from disk:"
{ $subsection all-vocabs } { $subsection all-vocabs }
{ $subsection all-vocabs-seq } { $subsection all-vocabs-recursive }
"Getting " { $link "vocabs.metadata" } " for all vocabularies on disk:" "Getting all vocabularies from disk whose names which match a string prefix:"
{ $subsection child-vocabs }
{ $subsection child-vocabs-recursive }
"Words for modifying output:"
{ $subsection no-roots }
{ $subsection no-prefixes }
"Getting " { $link "vocabs.metadata" } " for all vocabularies from disk:"
{ $subsection all-tags } { $subsection all-tags }
{ $subsection all-authors } ; { $subsection all-authors } ;
ABOUT: "vocabs.hierarchy" ABOUT: "vocabs.hierarchy"
HELP: all-vocabs
{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }
{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;
HELP: load HELP: load
{ $values { "prefix" string } } { $values { "prefix" string } }
{ $description "Load all vocabularies that match the provided prefix." } { $description "Load all vocabularies that match the provided prefix." }
@ -28,6 +30,3 @@ HELP: load
HELP: load-all HELP: load-all
{ $description "Load all vocabularies in the source tree." } ; { $description "Load all vocabularies in the source tree." } ;
HELP: all-vocabs-under
{ $values { "prefix" string } { "vocabs" "a sequence of vocabularies" } }
{ $description "Return a sequence of vocab or vocab-links for each vocab matching the provided prefix. Unlike " { $link all-child-vocabs } " this word will return both loaded and unloaded vocabularies." } ;

117
basis/vocabs/hierarchy/hierarchy.factor
View File

@ -1,11 +1,18 @@
! Copyright (C) 2007, 2009 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators.short-circuit fry USING: accessors arrays assocs combinators.short-circuit fry
io.directories io.files io.files.info io.pathnames kernel make io.directories io.files io.files.info io.pathnames kernel make
memoize namespaces sequences sorting splitting vocabs sets memoize namespaces sequences sorting splitting vocabs sets
vocabs.loader vocabs.metadata vocabs.errors ; vocabs.loader vocabs.metadata vocabs.errors ;
RENAME: child-vocabs vocabs => vocabs:child-vocabs
IN: vocabs.hierarchy IN: vocabs.hierarchy
TUPLE: vocab-prefix name ;
C: <vocab-prefix> vocab-prefix
M: vocab-prefix vocab-name name>> ;
<PRIVATE <PRIVATE
: vocab-subdirs ( dir -- dirs ) : vocab-subdirs ( dir -- dirs )
@ -15,74 +22,92 @@ IN: vocabs.hierarchy
] filter ] filter
] with-directory-files natural-sort ; ] with-directory-files natural-sort ;
: (all-child-vocabs) ( root name -- vocabs )
[
vocab-dir append-path dup exists?
[ vocab-subdirs ] [ drop { } ] if
] keep
[ '[ [ _ "." ] dip 3append ] map ] unless-empty ;
: vocab-dir? ( root name -- ? ) : vocab-dir? ( root name -- ? )
over over
[ ".factor" vocab-dir+ append-path exists? ] [ ".factor" vocab-dir+ append-path exists? ]
[ 2drop f ] [ 2drop f ]
if ; if ;
: vocabs-in-dir ( root name -- ) : (child-vocabs) ( root prefix -- vocabs )
dupd (all-child-vocabs) [ [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]
2dup vocab-dir? [ dup >vocab-link , ] when [ nip [ '[ [ _ "." ] dip 3append ] map ] unless-empty ]
vocabs-in-dir [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map ]
] with each ; 2tri ;
PRIVATE> : ((child-vocabs-recursive)) ( root name -- )
dupd vocab-name (child-vocabs)
[ dup , ((child-vocabs-recursive)) ] with each ;
: all-vocabs ( -- assoc ) : (child-vocabs-recursive) ( root name -- seq )
vocab-roots get [ [ ((child-vocabs-recursive)) ] { } make ;
dup [ "" vocabs-in-dir ] { } make
] { } map>assoc ;
: all-vocabs-under ( prefix -- vocabs ) : no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ;
[
[ vocab-roots get ] dip '[ _ vocabs-in-dir ] each
] { } make ;
MEMO: all-vocabs-seq ( -- seq ) : one-level-only? ( name prefix -- ? )
"" all-vocabs-under ; ?head [ "." split1 nip not ] dip and ;
<PRIVATE
: unrooted-child-vocabs ( prefix -- seq ) : unrooted-child-vocabs ( prefix -- seq )
[ vocabs no-rooted ] dip
dup empty? [ CHAR: . suffix ] unless dup empty? [ CHAR: . suffix ] unless
vocabs '[ vocab-name _ one-level-only? ] filter ;
[ find-vocab-root not ] filter
[ : unrooted-child-vocabs-recursive ( prefix -- seq )
vocab-name swap ?head CHAR: . rot member? not and vocabs:child-vocabs no-rooted ;
] with filter
[ vocab ] map ;
PRIVATE> PRIVATE>
: all-child-vocabs ( prefix -- assoc ) : no-prefixes ( seq -- seq' ) [ vocab-prefix? not ] filter ;
vocab-roots get [
dup pick (all-child-vocabs) [ >vocab-link ] map
] { } map>assoc
swap unrooted-child-vocabs f swap 2array suffix ;
: all-child-vocabs-seq ( prefix -- assoc ) : convert-prefixes ( seq -- seq' )
vocab-roots get swap '[ [ dup vocab-prefix? [ name>> vocab-link boa ] when ] map ;
dup _ (all-child-vocabs)
[ vocab-dir? ] with filter : remove-redundant-prefixes ( seq -- seq' )
] map concat ; #! Hack.
[ vocab-prefix? ] partition
[
[ vocab-name ] map unique
'[ name>> _ key? not ] filter
convert-prefixes
] keep
append ;
: no-roots ( assoc -- seq ) values concat ;
: child-vocabs ( prefix -- assoc )
[ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ]
[ unrooted-child-vocabs [ vocab ] map f swap 2array ]
bi suffix ;
: all-vocabs ( -- assoc )
"" child-vocabs ;
: child-vocabs-recursive ( prefix -- assoc )
[ [ vocab-roots get ] dip '[ dup _ (child-vocabs-recursive) ] { } map>assoc ]
[ unrooted-child-vocabs-recursive [ vocab ] map f swap 2array ]
bi suffix ;
MEMO: all-vocabs-recursive ( -- assoc )
"" child-vocabs-recursive ;
: all-vocab-names ( -- seq )
all-vocabs-recursive no-roots no-prefixes [ vocab-name ] map ;
: child-vocab-names ( prefix -- seq )
child-vocabs no-roots no-prefixes [ vocab-name ] map ;
<PRIVATE <PRIVATE
: filter-unportable ( seq -- seq' ) : filter-unportable ( seq -- seq' )
[ vocab-name unportable? not ] filter ; [ vocab-name unportable? not ] filter ;
: collect-vocabs ( quot -- seq )
[ all-vocabs-recursive no-roots no-prefixes ] dip
gather natural-sort ; inline
PRIVATE> PRIVATE>
: (load) ( prefix -- failures ) : (load) ( prefix -- failures )
all-vocabs-under child-vocabs-recursive no-roots no-prefixes
filter-unportable filter-unportable
require-all ; require-all ;
@ -92,8 +117,6 @@ PRIVATE>
: load-all ( -- ) : load-all ( -- )
"" load ; "" load ;
MEMO: all-tags ( -- seq ) MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;
all-vocabs-seq [ vocab-tags ] gather natural-sort ;
MEMO: all-authors ( -- seq ) MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;
all-vocabs-seq [ vocab-authors ] gather natural-sort ;

2
core/byte-vectors/byte-vectors.factor
View File

@ -26,6 +26,8 @@ M: byte-vector new-sequence
M: byte-vector equal? M: byte-vector equal?
over byte-vector? [ sequence= ] [ 2drop f ] if ; over byte-vector? [ sequence= ] [ 2drop f ] if ;
M: byte-vector contract 2drop ;
M: byte-array like M: byte-array like
#! If we have an byte-array, we're done. #! If we have an byte-array, we're done.
#! If we have a byte-vector, and it's at full capacity, #! If we have a byte-vector, and it's at full capacity,

8
core/growable/growable.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private USING: accessors kernel kernel.private math math.private
sequences sequences.private ; sequences sequences.private ;
@ -18,10 +18,12 @@ M: growable set-nth-unsafe underlying>> set-nth-unsafe ;
: expand ( len seq -- ) : expand ( len seq -- )
[ resize ] change-underlying drop ; inline [ resize ] change-underlying drop ; inline
: contract ( len seq -- ) GENERIC: contract ( len seq -- )
M: growable contract ( len seq -- )
[ length ] keep [ length ] keep
[ [ 0 ] 2dip set-nth-unsafe ] curry [ [ 0 ] 2dip set-nth-unsafe ] curry
(each-integer) ; inline (each-integer) ;
: growable-check ( n seq -- n seq ) : growable-check ( n seq -- n seq )
over 0 < [ bounds-error ] when ; inline over 0 < [ bounds-error ] when ; inline

4
extra/benchmark/benchmark.factor
View File

@ -13,7 +13,7 @@ SYMBOL: errors
PRIVATE> PRIVATE>
: run-benchmark ( vocab -- ) : run-benchmark ( vocab -- )
[ "=== " write vocab-name print flush ] [ [ "=== " write print flush ] [
[ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ] [ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ]
[ swap errors ] [ swap errors ]
recover get set-at recover get set-at
@ -23,7 +23,7 @@ PRIVATE>
[ [
V{ } clone timings set V{ } clone timings set
V{ } clone errors set V{ } clone errors set
"benchmark" all-child-vocabs-seq "benchmark" child-vocab-names
[ run-benchmark ] each [ run-benchmark ] each
timings get timings get
errors get errors get

1
extra/benchmark/hashtables/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

75
extra/benchmark/hashtables/hashtables.factor Normal file
View File

@ -0,0 +1,75 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators kernel locals math
math.ranges memoize sequences strings hashtables
math.parser grouping ;
IN: benchmark.hashtables
MEMO: strings ( -- str )
1 100 [a,b] 1 [ + ] accumulate nip [ number>string ] map ;
:: add-delete-mix ( hash keys -- )
keys [| k |
0 k hash set-at
k hash delete-at
] each
keys [
0 swap hash set-at
] each
keys [
hash delete-at
] each ;
:: store-lookup-mix ( hash keys -- )
keys [
0 swap hash set-at
] each
keys [
hash at
] map drop
keys [
hash [ 1 + ] change-at
] each ;
: string-mix ( hash -- )
strings
[ add-delete-mix ]
[ store-lookup-mix ]
2bi ;
TUPLE: collision value ;
M: collision hashcode* value>> hashcode* 15 bitand ;
: collision-mix ( hash -- )
strings 30 head [ collision boa ] map
[ add-delete-mix ]
[ store-lookup-mix ]
2bi ;
: small-mix ( hash -- )
strings 10 group [
[ add-delete-mix ]
[ store-lookup-mix ]
2bi
] with each ;
: hashtable-benchmark ( -- )
H{ } clone
10000 [
dup {
[ small-mix ]
[ clear-assoc ]
[ string-mix ]
[ clear-assoc ]
[ collision-mix ]
[ clear-assoc ]
} cleave
] times
drop ;
MAIN: hashtable-benchmark

6
extra/fuel/help/help.factor
View File

@ -6,7 +6,7 @@ help.markup help.topics io io.streams.string kernel make namespaces
parser prettyprint sequences summary help.vocabs parser prettyprint sequences summary help.vocabs
vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see
listener ; listener ;
FROM: vocabs.hierarchy => child-vocabs ;
IN: fuel.help IN: fuel.help
<PRIVATE <PRIVATE
@ -67,10 +67,10 @@ SYMBOL: describe-words
[ fuel-vocab-help-table ] bi* [ fuel-vocab-help-table ] bi*
[ 2array ] [ drop f ] if* [ 2array ] [ drop f ] if*
] if-empty ] if-empty
] { } assoc>map [ ] filter ; ] { } assoc>map sift ;
: fuel-vocab-children-help ( name -- element ) : fuel-vocab-children-help ( name -- element )
all-child-vocabs fuel-vocab-list ; inline child-vocabs fuel-vocab-list ; inline
: fuel-vocab-describe-words ( name -- element ) : fuel-vocab-describe-words ( name -- element )
[ words. ] with-string-writer \ describe-words swap 2array ; inline [ words. ] with-string-writer \ describe-words swap 2array ; inline

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

@ -64,7 +64,7 @@ PRIVATE>
: article-location ( name -- loc ) article loc>> get-loc ; : article-location ( name -- loc ) article loc>> get-loc ;
: get-vocabs ( -- seq ) all-vocabs-seq [ vocab-name ] map ; : get-vocabs ( -- seq ) all-vocab-names ;
: get-vocabs/prefix ( prefix -- seq ) get-vocabs swap filter-prefix ; : get-vocabs/prefix ( prefix -- seq ) get-vocabs swap filter-prefix ;

19
extra/webkit-demo/webkit-demo.factor
View File

@ -1,12 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel USING: cocoa cocoa.application cocoa.types cocoa.classes cocoa.windows
cocoa core-graphics.types kernel math.bitwise ;
cocoa.application
cocoa.types
cocoa.classes
cocoa.windows
core-graphics.types ;
IN: webkit-demo IN: webkit-demo
FRAMEWORK: /System/Library/Frameworks/WebKit.framework FRAMEWORK: /System/Library/Frameworks/WebKit.framework
@ -18,8 +13,16 @@ IMPORT: WebView
WebView -> alloc WebView -> alloc
rect f f -> initWithFrame:frameName:groupName: ; rect f f -> initWithFrame:frameName:groupName: ;
: window-style ( -- n )
{
NSClosableWindowMask
NSMiniaturizableWindowMask
NSResizableWindowMask
NSTitledWindowMask
} flags ;
: <WebWindow> ( -- id ) : <WebWindow> ( -- id )
<WebView> rect <ViewWindow> ; <WebView> rect window-style <ViewWindow> ;
: load-url ( window url -- ) : load-url ( window url -- )
[ -> contentView ] [ <NSString> ] bi* -> setMainFrameURL: ; [ -> contentView ] [ <NSString> ] bi* -> setMainFrameURL: ;