diff --git a/basis/alien/inline/compiler/compiler.factor b/basis/alien/inline/compiler/compiler.factor
index 0ac702478b..b5a7861d6b 100644
--- a/basis/alien/inline/compiler/compiler.factor
+++ b/basis/alien/inline/compiler/compiler.factor
@@ -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 ;
diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor
index 8e58071427..ae4a95497a 100644
--- a/basis/alien/inline/inline.factor
+++ b/basis/alien/inline/inline.factor
@@ -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 ;
diff --git a/basis/alien/inline/types/authors.txt b/basis/alien/inline/types/authors.txt
new file mode 100644
index 0000000000..c45c6f3279
--- /dev/null
+++ b/basis/alien/inline/types/authors.txt
@@ -0,0 +1 @@
+Jeremy Hughes
\ No newline at end of file
diff --git a/basis/alien/inline/types/types.factor b/basis/alien/inline/types/types.factor
new file mode 100644
index 0000000000..acc62a81a2
--- /dev/null
+++ b/basis/alien/inline/types/types.factor
@@ -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> ;
diff --git a/basis/bit-vectors/bit-vectors-docs.factor b/basis/bit-vectors/bit-vectors-docs.factor
index f0e4e47586..66d3d603fe 100644
--- a/basis/bit-vectors/bit-vectors-docs.factor
+++ b/basis/bit-vectors/bit-vectors-docs.factor
@@ -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{
diff --git a/basis/bit-vectors/bit-vectors.factor b/basis/bit-vectors/bit-vectors.factor
index a238f61244..7febe6fc1b 100644
--- a/basis/bit-vectors/bit-vectors.factor
+++ b/basis/bit-vectors/bit-vectors.factor
@@ -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 ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 1a1b2fd65c..abbb86cb16 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -261,4 +261,3 @@ INSN: _reload dst class n ;
INSN: _copy dst src class ;
INSN: _spill-counts counts ;
-SYMBOL: spill-temp
diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index 4a58064582..7dd3977605 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -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* ;
diff --git a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor
index b2b9202204..e99c2ba710 100644
--- a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor
@@ -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 -- )
diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
index e5c4b10021..9949832294 100644
--- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
@@ -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 ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
index e31fcedace..71d3d56285 100644
--- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
@@ -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
diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
index a17a1181b5..3e646b40f0 100644
--- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
@@ -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 ;
\ No newline at end of file
+ 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 ;
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index 6b7fdd8ce1..c995569c2e 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -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
diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor
index be3fb2bea8..a350ee5f43 100644
--- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor
+++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor
@@ -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 )
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 63d31dfb4e..b5999838ca 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -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
\ No newline at end of file
+[ _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
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor
index 2d3ad41b22..9013389cc9 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan.factor
@@ -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' )
[
diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
index ca8140f1c6..bf7e8bc042 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -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
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor
index 6734f6a359..ac18b0cb2e 100644
--- a/basis/compiler/cfg/linear-scan/numbering/numbering.factor
+++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor
@@ -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 ;
\ No newline at end of file
+ ] 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 ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index 4c27e5c4eb..7e308cf231 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -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 } }
}
] [
{
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index 951e727375..196d8e439f 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -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 ;
diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor
index f81490bcf2..da6a589031 100644
--- a/basis/editors/editors.factor
+++ b/basis/editors/editors.factor
@@ -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
diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index b7dab0d6af..6ffc4d8112 100644
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -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) ;
diff --git a/basis/help/apropos/apropos.factor b/basis/help/apropos/apropos.factor
index 63cbcb3f1e..3bcc815191 100644
--- a/basis/help/apropos/apropos.factor
+++ b/basis/help/apropos/apropos.factor
@@ -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
diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor
index fbfc42829e..84f708a687 100644
--- a/basis/help/html/html.factor
+++ b/basis/help/html/html.factor
@@ -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 )
[
diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor
index 1fb836427a..e0cea42b4f 100755
--- a/basis/help/lint/lint.factor
+++ b/basis/help/lint/lint.factor
@@ -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
diff --git a/basis/help/vocabs/vocabs.factor b/basis/help/vocabs/vocabs.factor
index b23143e572..7d99493691 100644
--- a/basis/help/vocabs/vocabs.factor
+++ b/basis/help/vocabs/vocabs.factor
@@ -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 [
diff --git a/basis/present/present-tests.factor b/basis/present/present-tests.factor
index e908fd8147..96aa7b24f2 100644
--- a/basis/present/present-tests.factor
+++ b/basis/present/present-tests.factor
@@ -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
\ No newline at end of file
+[ ] [ all-vocabs-recursive no-roots no-prefixes [ present ] map drop ] unit-test
\ No newline at end of file
diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor
index 412e5b4689..6635fbeaf2 100644
--- a/basis/specialized-vectors/functor/functor.factor
+++ b/basis/specialized-vectors/functor/functor.factor
@@ -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{ \ } ;
diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor
index 8ce45ccc15..7347b94628 100755
--- a/basis/struct-arrays/struct-arrays-tests.factor
+++ b/basis/struct-arrays/struct-arrays-tests.factor
@@ -35,4 +35,6 @@ C-STRUCT: test-struct
10 "test-struct" malloc-struct-array
&free drop
] with-destructors
-] unit-test
\ No newline at end of file
+] unit-test
+
+[ 15 ] [ 15 10 "point" <struct-array> resize length ] unit-test
\ No newline at end of file
diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor
index c21dae864a..60b9af0f19 100755
--- a/basis/struct-arrays/struct-arrays.factor
+++ b/basis/struct-arrays/struct-arrays.factor
@@ -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
diff --git a/basis/struct-vectors/struct-vectors-docs.factor b/basis/struct-vectors/struct-vectors-docs.factor
new file mode 100644
index 0000000000..368b054565
--- /dev/null
+++ b/basis/struct-vectors/struct-vectors-docs.factor
@@ -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"
diff --git a/basis/struct-vectors/struct-vectors-tests.factor b/basis/struct-vectors/struct-vectors-tests.factor
new file mode 100644
index 0000000000..cff65d3371
--- /dev/null
+++ b/basis/struct-vectors/struct-vectors-tests.factor
@@ -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
\ No newline at end of file
diff --git a/basis/struct-vectors/struct-vectors.factor b/basis/struct-vectors/struct-vectors.factor
new file mode 100644
index 0000000000..252a46d640
--- /dev/null
+++ b/basis/struct-vectors/struct-vectors.factor
@@ -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
\ No newline at end of file
diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor
index cacc628e2a..dec44625f7 100644
--- a/basis/threads/threads.factor
+++ b/basis/threads/threads.factor
@@ -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
diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor
index c8fd3a6658..fb664c495c 100644
--- a/basis/tools/completion/completion.factor
+++ b/basis/tools/completion/completion.factor
@@ -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 ;
diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor
index 390e652ac6..3beb0af79f 100644
--- a/basis/ui/gadgets/tables/tables.factor
+++ b/basis/ui/gadgets/tables/tables.factor
@@ -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>
diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor
index 7ea34e651f..42bc0ef1f2 100644
--- a/basis/ui/tools/tools.factor
+++ b/basis/ui/tools/tools.factor
@@ -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 }
diff --git a/basis/vectors/functor/functor.factor b/basis/vectors/functor/functor.factor
new file mode 100644
index 0000000000..47a6c2090a
--- /dev/null
+++ b/basis/vectors/functor/functor.factor
@@ -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
diff --git a/basis/vocabs/cache/cache.factor b/basis/vocabs/cache/cache.factor
index 63a8d6d292..24ccd391f1 100644
--- a/basis/vocabs/cache/cache.factor
+++ b/basis/vocabs/cache/cache.factor
@@ -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 ;
diff --git a/basis/vocabs/hierarchy/hierarchy-docs.factor b/basis/vocabs/hierarchy/hierarchy-docs.factor
index 3bea362582..8eb39732c0 100644
--- a/basis/vocabs/hierarchy/hierarchy-docs.factor
+++ b/basis/vocabs/hierarchy/hierarchy-docs.factor
@@ -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." } ;
diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor
index 046ccb8c2d..aa3e619660 100644
--- a/basis/vocabs/hierarchy/hierarchy.factor
+++ b/basis/vocabs/hierarchy/hierarchy.factor
@@ -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 ;
\ No newline at end of file
+MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;
diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor
index c273cea867..fc3d9501c7 100644
--- a/core/byte-vectors/byte-vectors.factor
+++ b/core/byte-vectors/byte-vectors.factor
@@ -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,
diff --git a/core/growable/growable.factor b/core/growable/growable.factor
index 684aab1158..754a3293d1 100644
--- a/core/growable/growable.factor
+++ b/core/growable/growable.factor
@@ -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
diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor
index 6c64e34835..ca71e22e9f 100755
--- a/extra/benchmark/benchmark.factor
+++ b/extra/benchmark/benchmark.factor
@@ -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
diff --git a/extra/benchmark/hashtables/authors.txt b/extra/benchmark/hashtables/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/extra/benchmark/hashtables/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/extra/benchmark/hashtables/hashtables.factor b/extra/benchmark/hashtables/hashtables.factor
new file mode 100644
index 0000000000..065ad9c34a
--- /dev/null
+++ b/extra/benchmark/hashtables/hashtables.factor
@@ -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
\ No newline at end of file
diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor
index f20e67f9bc..dcf5d69a74 100644
--- a/extra/fuel/help/help.factor
+++ b/extra/fuel/help/help.factor
@@ -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
diff --git a/extra/fuel/xref/xref.factor b/extra/fuel/xref/xref.factor
index 608667bae7..86aa215e21 100644
--- a/extra/fuel/xref/xref.factor
+++ b/extra/fuel/xref/xref.factor
@@ -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 ;
diff --git a/extra/webkit-demo/webkit-demo.factor b/extra/webkit-demo/webkit-demo.factor
index 728764226e..e6178a55c3 100644
--- a/extra/webkit-demo/webkit-demo.factor
+++ b/extra/webkit-demo/webkit-demo.factor
@@ -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: ;