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" ] }
} 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 -- )
name ".o" append temp-file
contents name lang src-suffix append temp-file
[ 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 -- )
[ "lib" prepend library-suffix append ] [ ".o" append ] bi
[ temp-file ] bi@ 2array
os {
{ [ dup linux? ]
[ drop { "gcc" "-shared" "-o" } ] }
{ [ dup macosx? ]
[ drop { "gcc" "-g" "-prebind" "-dynamiclib" "-o" } ] }
[ name>> "unimplemented for: " prepend throw ]
} cond prepend prepend try-process ;
:: link-object ( lang args name -- )
args name [ "lib" prepend library-suffix append ]
[ ".o" append ] bi [ temp-file ] bi@ 2array
lang link-command try-process ;
:: compile-to-library ( lang args contents name -- )
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.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.inline.compiler alien.libraries
alien.parser arrays fry generalizations io.files io.files.info
io.files.temp kernel lexer math.order multiline namespaces
sequences system vocabs.loader vocabs.parser words ;
USING: accessors alien.inline.compiler alien.inline.types
alien.libraries alien.parser arrays assocs effects fry
generalizations grouping io.files io.files.info io.files.temp
kernel lexer math math.order math.ranges multiline namespaces
sequences splitting strings system vocabs.loader
vocabs.parser words ;
IN: alien.inline
<PRIVATE
@ -12,21 +14,34 @@ SYMBOL: library-is-c++
SYMBOL: compiler-args
SYMBOL: c-strings
: return-library-function-params ( -- return library function params )
scan c-library get scan ")" parse-tokens
[ "(" subseq? not ] filter [
[ dup CHAR: - = [ drop CHAR: space ] when ] map
] 3dip ;
: function-types-effect ( -- function types effect )
scan scan swap ")" parse-tokens
[ "(" subseq? not ] filter swap parse-arglist ;
: factor-function ( return library function params -- )
[ dup "const " head? [ 6 tail ] when ] 3dip
make-function define-declared ;
: arg-list ( types -- params )
CHAR: a swap length CHAR: a + [a,b]
[ 1string ] map ;
: c-function-string ( return library function params -- str )
[ nip ] dip
" " join "(" prepend ")" append 3array " " join
: factor-function ( function types effect -- word quot effect )
annotate-effect [ c-library get ] 3dip
[ [ 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 ;
: 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 )
"lib" c-library get library-suffix
3array concat temp-file ;
@ -53,10 +68,14 @@ PRIVATE>
compile-library? [ compile-library ] when
c-library get library-path "cdecl" add-library ;
: define-c-function ( return library function params -- )
[ factor-function ] 4 nkeep c-function-string
" {\n" append parse-here append "\n}\n" append
c-strings get push ;
: define-c-function ( function types effect -- )
[ factor-function define-declared ] 3keep prototype-string
append-function-body 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 -- )
"-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-FUNCTION:
return-library-function-params define-c-function ;
function-types-effect define-c-function ;
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." } ;
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." } ;
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." } ;
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.
USING: arrays kernel kernel.private math sequences
sequences.private growable bit-arrays prettyprint.custom
parser accessors ;
parser accessors vectors.functor classes.parser ;
IN: bit-vectors
TUPLE: bit-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
<< "bit-vector" create-class-in \ bit-array \ <bit-array> define-vector >>
SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;
M: bit-vector contract 2drop ;
M: bit-vector >pprint-sequence ;
M: bit-vector pprint-delims drop \ ?V{ \ } ;
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: _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 ;
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 -- )
[ vreg>> active-intervals-for ] dip
'[ [ 0 ] dip reg>> _ add-use-position ] each ;
@ -21,7 +16,7 @@ IN: compiler.cfg.linear-scan.allocation
: inactive-positions ( new assoc -- )
[ [ 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
] each ;
@ -33,12 +28,6 @@ IN: compiler.cfg.linear-scan.allocation
: no-free-registers? ( result -- ? )
second 0 = ; inline
: register-available? ( new result -- ? )
[ end>> ] [ second ] bi* < ; inline
: register-available ( new result -- )
first >>reg add-active ;
: register-partially-available ( new result -- )
[ second split-before-use ] keep
'[ _ 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 )
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
[ relevant-ranges intersect-live-ranges 1/0. = ] with all? ;
[ intervals-intersect? not ] with all? ;
: coalesce? ( live-interval -- ? )
{
[ copy-from>> active-interval ]
[ [ start>> ] [ copy-from>> active-interval end>> ] bi = ]
[ intersects-inactive-intervals? ]
[ avoids-inactive-intervals? ]
} 1&& ;
: coalesce ( live-interval -- )

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

@ -1,23 +1,13 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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.splitting
compiler.cfg.linear-scan.live-intervals ;
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 ;
: check-ranges ( live-interval -- )
@ -47,52 +37,108 @@ ERROR: bad-live-ranges interval ;
[ ]
} 2cleave ;
: assign-spill ( live-interval -- live-interval )
dup vreg>> assign-spill-slot >>spill-to ;
: assign-spill ( live-interval -- )
dup vreg>> assign-spill-slot >>spill-to drop ;
: assign-reload ( before after -- before after )
over spill-to>> >>reload-from ;
: assign-reload ( live-interval -- )
dup vreg>> assign-spill-slot >>reload-from drop ;
: split-and-spill ( new existing -- before after )
swap start>> split-for-spill [ assign-spill ] dip assign-reload ;
: split-and-spill ( live-interval n -- before after )
split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ;
: reuse-register ( new existing -- )
[ nip delete-active ]
[ reg>> >>reg add-active ] 2bi ;
: find-use-position ( live-interval new -- n )
[ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ;
: spill-existing? ( new existing -- ? )
#! Test if 'new' will be used before 'existing'.
over start>> '[ _ [ > ] find-use -1 or ] bi@ < ;
: find-use-positions ( live-intervals new assoc -- )
'[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ;
: spill-existing ( new existing -- )
#! Our new interval will be used before the active interval
#! with the most distant use location. Spill the existing
#! 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 ;
: active-positions ( new assoc -- )
[ [ vreg>> active-intervals-for ] keep ] dip
find-use-positions ;
: spill-live-out? ( new existing -- ? )
[ start>> ] [ uses>> last ] bi* > ;
: inactive-positions ( new assoc -- )
[
[ vreg>> inactive-intervals-for ] keep
[ '[ _ intervals-intersect? ] filter ] keep
] dip
find-use-positions ;
: spill-live-out ( new existing -- )
#! The existing interval is never used again. Spill it and
#! re-use the register.
assign-spill
[ reuse-register ]
[ nip add-handled ] 2bi ;
: spill-status ( new -- use-pos )
H{ } clone
[ inactive-positions ] [ active-positions ] [ nip ] 2tri
>alist alist-max ;
: spill-new ( new existing -- )
#! Our new interval will be used after the active interval
#! 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 ;
: spill-new? ( new pair -- ? )
[ uses>> first ] [ second ] bi* > ;
: assign-blocked-register ( new -- )
[ dup vreg>> active-intervals-for ] keep interval-to-spill {
{ [ 2dup spill-live-out? ] [ spill-live-out ] }
{ [ 2dup spill-existing? ] [ spill-existing ] }
[ spill-new ]
: spill-new ( new pair -- )
drop
{
[ trim-after-ranges ]
[ 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 ;
: (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.
! See http://factorcode.org/license.txt for BSD license.
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.live-intervals ;
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-late ;
ERROR: splitting-atomic-interval ;
: check-split ( live-interval n -- )
[ [ start>> ] dip > [ splitting-too-early ] when ]
[ drop [ end>> ] [ start>> ] bi - 0 = [ splitting-atomic-interval ] when ]
2bi ; inline
check-allocation? get [
[ [ start>> ] dip > [ splitting-too-early ] when ]
[ [ end>> ] dip <= [ splitting-too-late ] when ]
[ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ]
2tri
] [ 2drop ] if ; inline
: split-before ( before -- before' )
f >>spill-to ; inline
@ -62,11 +67,12 @@ HINTS: split-interval live-interval object ;
2dup [ compute-start/end ] bi@ ;
: 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 )
! Find optimal split position
! Insert move instruction
1 -
2dup swap covers? [
[ '[ _ insert-use-for-copy ] change-uses ] keep

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

@ -1,10 +1,24 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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 ;
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
SYMBOL: registers
@ -32,11 +46,14 @@ SYMBOL: inactive-intervals
: add-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for push ;
: delete-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for delq ;
! Vector of handled live intervals
SYMBOL: handled-intervals
: add-handled ( live-interval -- )
handled-intervals get push ;
[ check-handled ] [ handled-intervals get push ] bi ;
: 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
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 -- )
[ check-progress ]
[ check-unhandled ]
[ dup start>> unhandled-intervals get heap-push ]
bi ;
@ -133,4 +141,16 @@ SYMBOL: spill-slots
: init-unhandled ( live-intervals -- )
[ [ 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
fry make combinators sets locals
cpu.architecture
compiler.cfg
compiler.cfg.def-use
compiler.cfg.liveness
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.allocation
@ -27,12 +29,6 @@ SYMBOL: unhandled-intervals
: init-unhandled ( live-intervals -- )
[ 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
SYMBOL: register-live-ins
@ -42,17 +38,10 @@ SYMBOL: register-live-outs
: init-assignment ( live-intervals -- )
V{ } clone pending-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-outs set
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 -- )
{
[ reg>> ]
@ -62,7 +51,7 @@ ERROR: already-spilled ;
} cleave f swap \ _spill boa , ;
: 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' )
dup split-before>> [ first-split ] [ ] ?if ;
@ -79,8 +68,7 @@ ERROR: already-spilled ;
} cleave f swap \ _copy boa , ;
: handle-copy ( live-interval -- )
dup [ spill-to>> not ] [ split-next>> ] bi and
[ insert-copy ] [ drop ] if ;
dup split-next>> [ insert-copy ] [ drop ] if ;
: expire-old-intervals ( n -- )
[ pending-intervals get ] dip '[
@ -88,22 +76,16 @@ ERROR: already-spilled ;
[ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
] 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 -- )
{
[ reg>> ]
[ vreg>> reg-class>> ]
[ reload-from>> ]
[ end>> ]
[ start>> ]
} cleave f swap \ _reload boa , ;
: 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 -- )
#! Any live intervals which start on the current instruction
@ -137,45 +119,51 @@ ERROR: overlapping-registers intervals ;
: active-intervals ( n -- intervals )
pending-intervals get [ covers? ] with filter
check-assignment? get [
dup check-assignment
] when ;
check-assignment? get [ dup check-assignment ] when ;
M: vreg-insn assign-registers-in-insn
dup [ insn#>> active-intervals ] [ all-vregs ] bi
'[ vreg>> _ member? ] filter
dup [ all-vregs ] [ insn#>> active-intervals ] bi
'[ _ [ vreg>> = ] with find nip ] map
register-mapping
>>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
! This works because ##gc is always the first instruction
! in a block.
dup call-next-method
dup compute-live-gc-values >>live-values
basic-block get register-live-ins get at >>live-values
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 -- )
dup block-from 1 - prepare-insn
[ block-from compute-live-values ] keep register-live-ins get set-at ;
dup basic-block set
dup block-from prepare-insn
[ [ live-in ] [ block-from ] bi compute-live-values ] keep
register-live-ins get set-at ;
: 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 ;
@ -190,10 +178,12 @@ ERROR: bad-vreg vreg ;
[
bb begin-block
[
[ insn#>> prepare-insn ]
[ assign-registers-in-insn ]
[ , ]
tri
{
[ insn#>> 1 - prepare-insn ]
[ insn#>> prepare-insn ]
[ assign-registers-in-insn ]
[ , ]
} cleave
] each
bb end-block
] 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.
USING: accessors kernel sequences sets arrays math strings fry
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
: check-assigned ( live-intervals -- )
@ -19,7 +19,10 @@ IN: compiler.cfg.linear-scan.debugger
] [ 1array ] if ;
: 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 ;
: picture ( uses -- str )

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

@ -1,7 +1,7 @@
IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors locals
math.order grouping
math.order grouping strings strings.private
cpu.architecture
compiler.cfg
compiler.cfg.optimizer
@ -13,6 +13,7 @@ compiler.cfg.rpo
compiler.cfg.linearization
compiler.cfg.debugger
compiler.cfg.linear-scan
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
@ -24,6 +25,7 @@ FROM: compiler.cfg.linear-scan.assignment => check-assignment? ;
check-allocation? on
check-assignment? on
check-numbering? on
[
{ 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
] 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
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
@ -209,86 +181,130 @@ check-assignment? on
[
T{ live-interval
{ 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 }
{ 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
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ 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 } }
}
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
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
}
interval-to-spill
spill-status
] unit-test
[ t ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 15 }
{ uses V{ 5 10 15 } }
[
{
1
1/0.
}
] [
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
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ 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 } } }
{ vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 20 }
{ uses V{ 1 7 20 } }
}
spill-existing?
spill-status
] unit-test
[ ] [
@ -1427,6 +1443,20 @@ USING: math.private ;
intersect-live-ranges
] 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 ] [
T{ live-interval
{ start 0 }
@ -1555,12 +1585,14 @@ V{
SYMBOL: linear-scan-result
:: test-linear-scan-on-cfg ( regs -- )
cfg new 0 get >>entry
compute-predecessors
compute-liveness
dup reverse-post-order
{ { int-regs regs } } (linear-scan)
flatten-cfg 1array mr. ;
[
cfg new 0 get >>entry
compute-predecessors
compute-liveness
dup reverse-post-order
{ { int-regs regs } } (linear-scan)
flatten-cfg 1array mr.
] with-scope ;
! 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
[ f ] [ 3 get instructions>> [ _reload? ] any? ] unit-test
[ _reload ] [ 4 get instructions>> first class ] unit-test
! Resolve pass
@ -1975,4 +2009,529 @@ V{
[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test
! 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 compute-live-intervals machine-registers allocate-registers
rpo assign-registers
rpo resolve-data-flow ;
rpo resolve-data-flow
rpo check-numbering ;
: 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
swap >>vreg ;
: block-from ( bb -- n ) instructions>> first insn#>> ;
: block-from ( bb -- n ) instructions>> first insn#>> 1 - ;
: block-to ( bb -- n ) instructions>> last insn#>> ;
@ -145,8 +145,7 @@ M: ##copy-float compute-live-intervals*
<reversed> [ compute-live-intervals-step ] each
] keep values dup finish-live-intervals ;
: relevant-ranges ( new inactive -- new' inactive' )
! Slice off all ranges of 'inactive' that precede the start of 'new'
: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
: intersect-live-range ( range1 range2 -- n/f )
@ -155,8 +154,8 @@ M: ##copy-float compute-live-intervals*
: intersect-live-ranges ( ranges1 ranges2 -- n )
{
{ [ over empty? ] [ 2drop 1/0. ] }
{ [ dup empty? ] [ 2drop 1/0. ] }
{ [ over empty? ] [ 2drop f ] }
{ [ dup empty? ] [ 2drop f ] }
[
2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
drop
@ -166,3 +165,6 @@ M: ##copy-float compute-live-intervals*
] if
]
} cond ;
: intervals-intersect? ( interval1 interval2 -- ? )
relevant-ranges intersect-live-ranges >boolean ; inline

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

@ -1,6 +1,6 @@
! Copyright (C) 2009 Slava Pestov.
! 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
: number-instructions ( rpo -- )
@ -8,4 +8,15 @@ IN: compiler.cfg.linear-scan.numbering
instructions>> [
[ (>>insn#) ] [ drop 2 + ] 2bi
] 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.live-intervals
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.resolve compiler.cfg.predecessors
compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel
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
] 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{ _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{ _reload { dst 0 } { class int-regs } { n spill-temp } }
T{ _spill { src 1 } { class float-regs } { n spill-temp } }
T{ _reload { dst 0 } { class int-regs } { n 10 } }
T{ _spill { src 1 } { class float-regs } { n 20 } }
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 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 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 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 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 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{ _spill { src 4 } { class int-regs } { n 10 } }
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{ _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
combinators combinators.short-circuit fry hashtables kernel locals
make math math.order namespaces sequences sets words parser
compiler.cfg.instructions compiler.cfg.linear-scan.assignment
compiler.cfg.liveness ;
compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.assignment compiler.cfg.liveness ;
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 ;
@ -116,11 +121,15 @@ ERROR: resolve-error ;
: break-cycle-n ( operations -- operations' )
split-cycle [
[ from>> spill-temp <spill-slot> ]
[ reg-class>> ] bi \ register->memory boa
[ from>> ]
[ reg-class>> spill-temp <spill-slot> ]
[ reg-class>> ]
tri \ register->memory boa
] [
[ to>> spill-temp <spill-slot> swap ]
[ reg-class>> ] bi \ memory->register boa
[ reg-class>> spill-temp <spill-slot> ]
[ to>> ]
[ reg-class>> ]
tri \ memory->register boa
] bi [ 1array ] bi@ surround ;
: break-cycle ( operations -- operations' )
@ -197,4 +206,5 @@ ERROR: resolve-error ;
dup successors>> [ resolve-edge-data-flow ] with each ;
: resolve-data-flow ( rpo -- )
H{ } clone spill-temps set
[ resolve-block-data-flow ] each ;

5
basis/editors/editors.factor
View File

@ -3,8 +3,9 @@
USING: parser lexer kernel namespaces sequences definitions
io.files io.backend io.pathnames io summary continuations
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 ;
FROM: vocabs => vocab-name >vocab-link ;
IN: editors
TUPLE: no-edit-hook ;
@ -15,7 +16,7 @@ M: no-edit-hook summary
SYMBOL: edit-hook
: available-editors ( -- seq )
"editors" all-child-vocabs-seq [ vocab-name ] map ;
"editors" child-vocabs no-roots no-prefixes [ vocab-name ] map ;
: editor-restarts ( -- alist )
available-editors

2
basis/functors/functors.factor
View File

@ -121,6 +121,8 @@ PRIVATE>
SYNTAX: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ;
SYNTAX: DEFERS [ current-vocab create ] (INTERPOLATE) ;
SYNTAX: DEFINES [ create-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 ;
: 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 )
[ [ >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
vocabs.hierarchy help.vocabs namespaces prettyprint io
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: ascii => ascii? ;
IN: help.html
@ -24,6 +25,7 @@ IN: help.html
{ CHAR: / "__slash__" }
{ CHAR: , "__comma__" }
{ CHAR: @ "__at__" }
{ CHAR: # "__hash__" }
} at [ % ] [ , ] ?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 ;
: all-vocabs-really ( -- seq )
#! Hack.
all-vocabs values concat
vocabs [ find-vocab-root not ] filter [ vocab ] map append ;
all-vocabs >hashtable f over delete-at no-roots remove-redundant-prefixes ;
: 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
locals tools.errors listener ;
FROM: help.lint.checks => all-vocabs ;
FROM: vocabs => child-vocabs ;
IN: help.lint
SYMBOL: lint-failures
@ -79,7 +80,7 @@ PRIVATE>
: help-lint ( prefix -- )
[
auto-use? off
all-vocabs-seq [ vocab-name ] map all-vocabs set
all-vocab-names all-vocabs set
group-articles vocab-articles set
child-vocabs
[ 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
vocabs vocabs.files vocabs.hierarchy vocabs.loader
vocabs.metadata words words.symbol definitions.icons ;
FROM: vocabs.hierarchy => child-vocabs ;
IN: help.vocabs
: about ( vocab -- )
@ -35,7 +36,7 @@ IN: help.vocabs
$heading ;
: $vocabs ( seq -- )
[ vocab-row ] map vocab-headings prefix $table ;
convert-prefixes [ vocab-row ] map vocab-headings prefix $table ;
: $vocab-roots ( assoc -- )
[
@ -67,7 +68,8 @@ C: <vocab-author> vocab-author
] unless-empty ;
: describe-children ( vocab -- )
vocab-name all-child-vocabs $vocab-roots ;
vocab-name child-vocabs
$vocab-roots ;
: files. ( seq -- )
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
[ "+" ] [ \ + 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.
USING: functors sequences sequences.private growable
prettyprint.custom kernel words classes math parser ;
QUALIFIED: vectors.functor
IN: specialized-vectors.functor
FUNCTOR: define-vector ( T -- )
V DEFINES-CLASS ${T}-vector
A IS ${T}-array
<A> IS <${A}>
V DEFINES-CLASS ${T}-vector
<V> DEFINES <${V}>
>V DEFINES >${V}
>V DEFERS >${V}
V{ DEFINES ${V}{
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 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 contract 2drop ;
M: V pprint-delims drop \ V{ \ } ;

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

@ -35,4 +35,6 @@ C-STRUCT: test-struct
10 "test-struct" malloc-struct-array
&free drop
] 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
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 )
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 -- ? )
id>> threads key? ;
ERROR: already-stopped thread ;
: check-unregistered ( thread -- thread )
dup thread-registered?
[ "Thread already stopped" throw ] when ;
dup thread-registered? [ already-stopped ] when ;
ERROR: not-running thread ;
: check-registered ( thread -- thread )
dup thread-registered?
[ "Thread is not running" throw ] unless ;
dup thread-registered? [ not-running ] unless ;
<PRIVATE

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

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

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

@ -313,13 +313,14 @@ PRIVATE>
if ;
: row-action? ( table -- ? )
[ [ mouse-row ] keep valid-line? ]
[ single-click?>> hand-click# get 2 = or ] bi and ;
single-click?>> hand-click# get 2 = or ;
<PRIVATE
: 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>

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

@ -26,7 +26,6 @@ tool "tool-switching" f {
} define-command-map
tool "common" f {
{ T{ key-down f { A+ } "s" } save }
{ T{ key-down f { A+ } "w" } close-window }
{ T{ key-down f { A+ } "q" } com-exit }
{ 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 ( -- )
root-cache get-global clear-assoc
\ vocab-file-contents reset-memoized
\ all-vocabs-seq reset-memoized
\ all-vocabs-recursive reset-memoized
\ all-authors reset-memoized
\ all-tags reset-memoized ;

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

@ -7,19 +7,21 @@ $nl
"Loading vocabulary hierarchies:"
{ $subsection load }
{ $subsection load-all }
"Getting all vocabularies on disk:"
"Getting all vocabularies from disk:"
{ $subsection all-vocabs }
{ $subsection all-vocabs-seq }
"Getting " { $link "vocabs.metadata" } " for all vocabularies on disk:"
{ $subsection all-vocabs-recursive }
"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-authors } ;
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
{ $values { "prefix" string } }
{ $description "Load all vocabularies that match the provided prefix." }
@ -28,6 +30,3 @@ HELP: load
HELP: load-all
{ $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.
! 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
memoize namespaces sequences sorting splitting vocabs sets
vocabs.loader vocabs.metadata vocabs.errors ;
RENAME: child-vocabs vocabs => vocabs:child-vocabs
IN: vocabs.hierarchy
TUPLE: vocab-prefix name ;
C: <vocab-prefix> vocab-prefix
M: vocab-prefix vocab-name name>> ;
<PRIVATE
: vocab-subdirs ( dir -- dirs )
@ -15,74 +22,92 @@ IN: vocabs.hierarchy
] filter
] 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 -- ? )
over
[ ".factor" vocab-dir+ append-path exists? ]
[ 2drop f ]
if ;
: vocabs-in-dir ( root name -- )
dupd (all-child-vocabs) [
2dup vocab-dir? [ dup >vocab-link , ] when
vocabs-in-dir
] with each ;
: (child-vocabs) ( root prefix -- vocabs )
[ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]
[ nip [ '[ [ _ "." ] dip 3append ] map ] unless-empty ]
[ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map ]
2tri ;
PRIVATE>
: ((child-vocabs-recursive)) ( root name -- )
dupd vocab-name (child-vocabs)
[ dup , ((child-vocabs-recursive)) ] with each ;
: all-vocabs ( -- assoc )
vocab-roots get [
dup [ "" vocabs-in-dir ] { } make
] { } map>assoc ;
: (child-vocabs-recursive) ( root name -- seq )
[ ((child-vocabs-recursive)) ] { } make ;
: all-vocabs-under ( prefix -- vocabs )
[
[ vocab-roots get ] dip '[ _ vocabs-in-dir ] each
] { } make ;
: no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ;
MEMO: all-vocabs-seq ( -- seq )
"" all-vocabs-under ;
<PRIVATE
: one-level-only? ( name prefix -- ? )
?head [ "." split1 nip not ] dip and ;
: unrooted-child-vocabs ( prefix -- seq )
[ vocabs no-rooted ] dip
dup empty? [ CHAR: . suffix ] unless
vocabs
[ find-vocab-root not ] filter
[
vocab-name swap ?head CHAR: . rot member? not and
] with filter
[ vocab ] map ;
'[ vocab-name _ one-level-only? ] filter ;
: unrooted-child-vocabs-recursive ( prefix -- seq )
vocabs:child-vocabs no-rooted ;
PRIVATE>
: all-child-vocabs ( prefix -- assoc )
vocab-roots get [
dup pick (all-child-vocabs) [ >vocab-link ] map
] { } map>assoc
swap unrooted-child-vocabs f swap 2array suffix ;
: no-prefixes ( seq -- seq' ) [ vocab-prefix? not ] filter ;
: all-child-vocabs-seq ( prefix -- assoc )
vocab-roots get swap '[
dup _ (all-child-vocabs)
[ vocab-dir? ] with filter
] map concat ;
: convert-prefixes ( seq -- seq' )
[ dup vocab-prefix? [ name>> vocab-link boa ] when ] map ;
: remove-redundant-prefixes ( seq -- seq' )
#! 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
: filter-unportable ( seq -- seq' )
[ vocab-name unportable? not ] filter ;
: collect-vocabs ( quot -- seq )
[ all-vocabs-recursive no-roots no-prefixes ] dip
gather natural-sort ; inline
PRIVATE>
: (load) ( prefix -- failures )
all-vocabs-under
child-vocabs-recursive no-roots no-prefixes
filter-unportable
require-all ;
@ -92,8 +117,6 @@ PRIVATE>
: load-all ( -- )
"" load ;
MEMO: all-tags ( -- seq )
all-vocabs-seq [ vocab-tags ] gather natural-sort ;
MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;
MEMO: all-authors ( -- seq )
all-vocabs-seq [ vocab-authors ] gather natural-sort ;
MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;

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

@ -26,6 +26,8 @@ M: byte-vector new-sequence
M: byte-vector equal?
over byte-vector? [ sequence= ] [ 2drop f ] if ;
M: byte-vector contract 2drop ;
M: byte-array like
#! If we have an byte-array, we're done.
#! 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.
USING: accessors kernel kernel.private math math.private
sequences sequences.private ;
@ -18,10 +18,12 @@ M: growable set-nth-unsafe underlying>> set-nth-unsafe ;
: expand ( len seq -- )
[ resize ] change-underlying drop ; inline
: contract ( len seq -- )
GENERIC: contract ( len seq -- )
M: growable contract ( len seq -- )
[ length ] keep
[ [ 0 ] 2dip set-nth-unsafe ] curry
(each-integer) ; inline
(each-integer) ;
: growable-check ( n seq -- n seq )
over 0 < [ bounds-error ] when ; inline

4
extra/benchmark/benchmark.factor
View File

@ -13,7 +13,7 @@ SYMBOL: errors
PRIVATE>
: run-benchmark ( vocab -- )
[ "=== " write vocab-name print flush ] [
[ "=== " write print flush ] [
[ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ]
[ swap errors ]
recover get set-at
@ -23,7 +23,7 @@ PRIVATE>
[
V{ } clone timings set
V{ } clone errors set
"benchmark" all-child-vocabs-seq
"benchmark" child-vocab-names
[ run-benchmark ] each
timings 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
vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see
listener ;
FROM: vocabs.hierarchy => child-vocabs ;
IN: fuel.help
<PRIVATE
@ -67,10 +67,10 @@ SYMBOL: describe-words
[ fuel-vocab-help-table ] bi*
[ 2array ] [ drop f ] if*
] if-empty
] { } assoc>map [ ] filter ;
] { } assoc>map sift ;
: 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 )
[ 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 ;
: 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 ;

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

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