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

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

db4
Slava Pestov 2009-07-09 06:32:04 -05:00
parent d0f2b1c606 508b7272b5
commit 128c6c8e03
31 changed files with 688 additions and 561 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators fry generalizations
io.encodings.ascii io.files io.files.temp io.launcher kernel
locals sequences system ;
locals make sequences system vocabs.parser words ;
IN: alien.inline.compiler
SYMBOL: C
@ -15,37 +15,59 @@ SYMBOL: C++
{ [ dup windows? ] [ drop ".dll" ] }
} cond ;
: library-path ( str -- str' )
'[
"lib-" % current-vocab name>> %
"-" % _ % library-suffix %
] "" make temp-file ;
: src-suffix ( lang -- str )
{
{ C [ ".c" ] }
{ C++ [ ".cpp" ] }
} case ;
: compiler ( lang -- str )
HOOK: compiler os ( lang -- str )
M: word compiler ( lang -- str )
{
{ C [ "gcc" ] }
{ C++ [ "g++" ] }
} case ;
M: openbsd compiler ( lang -- str )
{
{ C [ "gcc" ] }
{ C++ [ "eg++" ] }
} case ;
HOOK: compiler-descr os ( lang -- descr )
M: word compiler-descr compiler 1array ;
M: macosx compiler-descr
call-next-method cpu x86.64?
[ { "-arch" "x86_64" } append ] when ;
HOOK: link-descr os ( -- descr )
M: word link-descr { "-shared" "-o" } ;
M: macosx link-descr
{ "-g" "-prebind" "-dynamiclib" "-o" }
cpu x86.64? [ { "-arch" "x86_64" } prepend ] when ;
: 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 ;
compiler-descr link-descr append 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
{ "-fPIC" "-c" "-o" } lang compiler prefix prepend
lang compiler-descr { "-fPIC" "-c" "-o" } append prepend
try-process ;
:: link-object ( lang args name -- )
args name [ "lib" prepend library-suffix append ]
[ ".o" append ] bi [ temp-file ] bi@ 2array
args name [ library-path ]
[ ".o" append temp-file ] bi 2array
lang link-command try-process ;
:: compile-to-library ( lang args contents name -- )

72
basis/alien/inline/inline-tests.factor Normal file
View File

@ -0,0 +1,72 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.inline alien.inline.private io.directories io.files
kernel namespaces tools.test alien.c-types alien.structs ;
IN: alien.inline.tests
DELETE-C-LIBRARY: test
C-LIBRARY: test
C-FUNCTION: const-int add ( int a, int b )
return a + b;
;
C-TYPEDEF: double bigfloat
C-FUNCTION: bigfloat smaller ( bigfloat a )
return a / 10;
;
C-STRUCTURE: rectangle
{ "int" "width" }
{ "int" "height" } ;
C-FUNCTION: int area ( rectangle c )
return c.width * c.height;
;
;C-LIBRARY
{ 2 1 } [ add ] must-infer-as
[ 5 ] [ 2 3 add ] unit-test
[ t ] [ "double" "bigfloat" [ resolve-typedef ] bi@ = ] unit-test
{ 1 1 } [ smaller ] must-infer-as
[ 1.0 ] [ 10 smaller ] unit-test
[ t ] [ "rectangle" resolve-typedef struct-type? ] unit-test
{ 1 1 } [ area ] must-infer-as
[ 20 ] [
"rectangle" <c-object>
4 over set-rectangle-width
5 over set-rectangle-height
area
] unit-test
DELETE-C-LIBRARY: cpplib
C-LIBRARY: cpplib
COMPILE-AS-C++
C-INCLUDE: <string>
C-FUNCTION: const-char* hello ( )
std::string s("hello world");
return s.c_str();
;
;C-LIBRARY
{ 0 1 } [ hello ] must-infer-as
[ "hello world" ] [ hello ] unit-test
DELETE-C-LIBRARY: compile-error
C-LIBRARY: compile-error
C-FUNCTION: char* breakme ( )
return not a string;
;
<< [ compile-c-library ] must-fail >>

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

@ -2,10 +2,11 @@
! See http://factorcode.org/license.txt for BSD license.
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 ;
generalizations grouping io.directories io.files
io.files.info io.files.temp kernel lexer math math.order
math.ranges multiline namespaces sequences source-files
splitting strings system vocabs.loader vocabs.parser words
alien.c-types alien.structs make parser ;
IN: alien.inline
<PRIVATE
@ -41,15 +42,12 @@ SYMBOL: c-strings
: 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 ;
: compile-library? ( -- ? )
library-path dup exists? [
current-vocab vocab-source-path
[ file-info modified>> ] bi@ <=> +lt+ =
c-library get library-path dup exists? [
file get [
path>>
[ file-info modified>> ] bi@ <=> +lt+ =
] [ drop t ] if*
] [ drop t ] if ;
: compile-library ( -- )
@ -66,7 +64,7 @@ PRIVATE>
: compile-c-library ( -- )
compile-library? [ compile-library ] when
c-library get library-path "cdecl" add-library ;
c-library get dup library-path "cdecl" add-library ;
: define-c-function ( function types effect -- )
[ factor-function define-declared ] 3keep prototype-string
@ -89,6 +87,25 @@ PRIVATE>
: define-c-include ( str -- )
"#include " prepend c-strings get push ;
: define-c-typedef ( old new -- )
[ typedef ] [
[ swap "typedef " % % " " % % ";" % ]
"" make c-strings get push
] 2bi ;
: define-c-struct ( name vocab fields -- )
[ define-struct ] [
nip over
[
"typedef struct " % "_" % % " {\n" %
[ first2 swap % " " % % ";\n" % ] each
"} " % % ";\n" %
] "" make c-strings get push
] 3bi ;
: delete-inline-library ( str -- )
library-path dup exists? [ delete-file ] [ drop ] if ;
SYNTAX: C-LIBRARY: scan define-c-library ;
SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
@ -104,4 +121,14 @@ SYNTAX: C-INCLUDE: scan define-c-include ;
SYNTAX: C-FUNCTION:
function-types-effect define-c-function ;
SYNTAX: C-TYPEDEF: scan scan define-c-typedef ;
SYNTAX: C-STRUCTURE:
scan current-vocab parse-definition define-c-struct ;
SYNTAX: ;C-LIBRARY compile-c-library ;
SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ;
SYNTAX: RAW-C:
[ "\n" % parse-here % "\n" % c-strings get push ] "" make ;

48
basis/alien/inline/tests/tests.factor
View File

@ -1,48 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test alien.inline alien.inline.private io.files
io.directories kernel ;
IN: alien.inline.tests
C-LIBRARY: const
C-FUNCTION: const-int add ( int a, int b )
return a + b;
;
;C-LIBRARY
{ 2 1 } [ add ] must-infer-as
[ 5 ] [ 2 3 add ] unit-test
<< library-path dup exists? [ delete-file ] [ drop ] if >>
C-LIBRARY: cpplib
COMPILE-AS-C++
C-INCLUDE: <string>
C-FUNCTION: const-char* hello ( )
std::string s("hello world");
return s.c_str();
;
;C-LIBRARY
{ 0 1 } [ hello ] must-infer-as
[ "hello world" ] [ hello ] unit-test
<< library-path dup exists? [ delete-file ] [ drop ] if >>
C-LIBRARY: compile-error
C-FUNCTION: char* breakme ( )
return not a string;
;
<< [ compile-c-library ] must-fail >>
<< library-path dup exists? [ delete-file ] [ drop ] if >>

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 ;

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

@ -28,16 +28,30 @@ IN: compiler.cfg.linear-scan.allocation
: no-free-registers? ( result -- ? )
second 0 = ; inline
: split-to-fit ( new n -- before after )
split-interval
[ [ compute-start/end ] bi@ ]
[ >>split-next drop ]
[ ]
2tri ;
: register-partially-available ( new result -- )
[ second split-before-use ] keep
'[ _ register-available ] [ add-unhandled ] bi* ;
{
{ [ 2dup second 1 - spill-live-out? ] [ drop spill-live-out ] }
{ [ 2dup second 1 - spill-live-in? ] [ drop spill-live-in ] }
[
[ second 1 - split-to-fit ] keep
'[ _ register-available ] [ add-unhandled ] bi*
]
} cond ;
: assign-register ( new -- )
dup coalesce? [ coalesce ] [
dup register-status {
{ [ dup no-free-registers? ] [ drop assign-blocked-register ] }
{ [ 2dup register-available? ] [ register-available ] }
[ register-partially-available ]
! [ register-partially-available ]
[ drop assign-blocked-register ]
} cond
] if ;

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

@ -38,7 +38,7 @@ ERROR: bad-live-ranges interval ;
} 2cleave ;
: assign-spill ( live-interval -- )
dup vreg>> assign-spill-slot >>spill-to drop ;
dup vreg>> assign-spill-slot >>spill-to f >>split-next drop ;
: assign-reload ( live-interval -- )
dup vreg>> assign-spill-slot >>reload-from drop ;
@ -80,10 +80,12 @@ ERROR: bad-live-ranges interval ;
[ add-unhandled ]
} cleave ;
: split-intersecting? ( live-interval new reg -- ? )
{ [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ;
: spill-live-out? ( live-interval n -- ? ) [ uses>> last ] dip < ;
: split-live-out ( live-interval -- )
: spill-live-out ( live-interval -- )
! The interval has no more usages after the spill location. This
! means it is the first child of an interval that was split. We
! spill the value and let the resolve pass insert a reload later.
{
[ trim-before-ranges ]
[ compute-start/end ]
@ -91,7 +93,13 @@ ERROR: bad-live-ranges interval ;
[ add-handled ]
} cleave ;
: split-live-in ( live-interval -- )
: spill-live-in? ( live-interval n -- ? ) [ uses>> first ] dip > ;
: spill-live-in ( live-interval -- )
! The interval does not have any usages before the spill location.
! This means it is the second child of an interval that was
! split. We reload the value and let the resolve pass insert a
! split later.
{
[ trim-after-ranges ]
[ compute-start/end ]
@ -99,40 +107,48 @@ ERROR: bad-live-ranges interval ;
[ 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 ] }
: spill ( live-interval n -- )
{
{ [ 2dup spill-live-out? ] [ drop spill-live-out ] }
{ [ 2dup spill-live-in? ] [ drop spill-live-in ] }
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ]
} cond ;
: (split-intersecting-active) ( active new -- )
[ drop delete-active ]
[ (split-intersecting) ] 2bi ;
:: spill-intersecting-active ( new reg -- )
! If there is an active interval using 'reg' (there should be at
! most one) are split and spilled and removed from the inactive
! set.
new vreg>> active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
'[ _ delete-nth new start>> spill ] [ 2drop ] if ;
: split-intersecting-active ( new reg -- )
[ [ vreg>> active-intervals-for ] keep ] dip
[ '[ _ _ split-intersecting? ] filter ] 2keep drop
'[ _ (split-intersecting-active) ] each ;
:: spill-intersecting-inactive ( new reg -- )
! Any inactive intervals using 'reg' are split and spilled
! and removed from the inactive set.
new vreg>> inactive-intervals-for [
dup reg>> reg = [
dup new intervals-intersect? [
new start>> spill f
] [ drop t ] if
] [ drop t ] if
] filter-here ;
: (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 ]
: spill-intersecting ( new reg -- )
! Split and spill all active and inactive intervals
! which intersect 'new' and use 'reg'.
[ spill-intersecting-active ]
[ spill-intersecting-inactive ]
2bi ;
: spill-available ( new pair -- )
[ first split-intersecting ] [ register-available ] 2bi ;
! A register would become fully available if all
! active and inactive intervals using it were split
! and spilled.
[ first spill-intersecting ] [ register-available ] 2bi ;
: spill-partially-available ( new pair -- )
! A register would be available for part of the new
! interval's lifetime if all active and inactive intervals
! using that register were split and spilled.
[ second 1 - split-and-spill add-unhandled ] keep
spill-available ;

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

@ -61,23 +61,3 @@ ERROR: splitting-atomic-interval ;
after split-after ;
HINTS: split-interval live-interval object ;
: split-between-blocks ( new n -- before after )
split-interval
2dup [ compute-start/end ] bi@ ;
: insert-use-for-copy ( seq n -- seq' )
[ '[ _ < ] filter ]
[ nip dup 1 + 2array ]
[ 1 + '[ _ > ] filter ]
2tri 3append ;
: split-before-use ( new n -- before after )
1 -
2dup swap covers? [
[ '[ _ insert-use-for-copy ] change-uses ] keep
split-between-blocks
2dup >>split-next drop
] [
split-between-blocks
] if ;

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

@ -8,6 +8,7 @@ compiler.cfg.def-use
compiler.cfg.liveness
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.mapping
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
@ -42,16 +43,11 @@ SYMBOL: register-live-outs
H{ } clone register-live-outs set
init-unhandled ;
: insert-spill ( live-interval -- )
{
[ reg>> ]
[ vreg>> reg-class>> ]
[ spill-to>> ]
[ end>> ]
} cleave f swap \ _spill boa , ;
: handle-spill ( live-interval -- )
dup spill-to>> [ insert-spill ] [ drop ] if ;
dup spill-to>> [
[ reg>> ] [ spill-to>> <spill-slot> ] [ vreg>> reg-class>> ] tri
register->memory
] [ drop ] if ;
: first-split ( live-interval -- live-interval' )
dup split-before>> [ first-split ] [ ] ?if ;
@ -59,22 +55,19 @@ SYMBOL: register-live-outs
: next-interval ( live-interval -- live-interval' )
split-next>> first-split ;
: insert-copy ( live-interval -- )
{
[ next-interval reg>> ]
[ reg>> ]
[ vreg>> reg-class>> ]
[ end>> ]
} cleave f swap \ _copy boa , ;
: handle-copy ( live-interval -- )
dup split-next>> [ insert-copy ] [ drop ] if ;
dup split-next>> [
[ reg>> ] [ next-interval reg>> ] [ vreg>> reg-class>> ] tri
register->register
] [ drop ] if ;
: expire-old-intervals ( n -- )
[ pending-intervals get ] dip '[
dup end>> _ <
[ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
] filter-here ;
[
[ pending-intervals get ] dip '[
dup end>> _ <
[ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
] filter-here
] { } make mapping-instructions % ;
: insert-reload ( live-interval -- )
{

56
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 strings strings.private
math.order grouping strings strings.private classes
cpu.architecture
compiler.cfg
compiler.cfg.optimizer
@ -153,56 +153,6 @@ check-numbering? on
} 10 split-for-spill [ 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 5 }
{ uses V{ 5 } }
{ ranges V{ T{ live-range f 5 5 } } }
}
] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } }
} 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 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 } } }
@ -225,7 +175,7 @@ check-numbering? on
{ 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@
} 4 split-to-fit [ f >>split-next ] bi@
] unit-test
[
@ -1847,8 +1797,6 @@ test-diamond
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
USING: classes ;
[ ] [
1 get instructions>> first regs>> V int-regs 0 swap at
2 get instructions>> first regs>> V int-regs 1 swap at assert=

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

@ -10,7 +10,8 @@ compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.resolve ;
compiler.cfg.linear-scan.resolve
compiler.cfg.linear-scan.mapping ;
IN: compiler.cfg.linear-scan
! References:
@ -36,6 +37,7 @@ IN: compiler.cfg.linear-scan
: linear-scan ( cfg -- cfg' )
[
init-mapping
dup reverse-post-order machine-registers (linear-scan)
spill-counts get >>spill-counts
] with-scope ;

145
basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor Normal file
View File

@ -0,0 +1,145 @@
USING: compiler.cfg.instructions
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.mapping cpu.architecture kernel
namespaces tools.test ;
IN: compiler.cfg.linear-scan.mapping.tests
H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
init-mapping
[
{
T{ _copy { dst 5 } { src 4 } { class int-regs } }
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 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 20 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _spill { src 2 } { class int-regs } { n 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 10 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _spill { src 0 } { class int-regs } { n 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 10 } }
}
] [
{
T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _copy { dst 2 } { src 0 } { class int-regs } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{ }
] [
{
T{ register->register { from 4 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _spill { src 3 } { class int-regs } { n 4 } }
T{ _reload { dst 2 } { class int-regs } { n 1 } }
}
] [
{
T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } }
T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _copy { dst 2 } { src 0 } { class int-regs } }
T{ _copy { dst 0 } { src 3 } { class int-regs } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _copy { dst 2 } { src 0 } { class int-regs } }
T{ _spill { src 4 } { class int-regs } { n 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 10 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 2 } { src 0 } { class int-regs } }
T{ _copy { dst 9 } { src 1 } { class int-regs } }
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _spill { src 4 } { class int-regs } { n 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 10 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
T{ register->register { from 1 } { to 9 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test

148
basis/compiler/cfg/linear-scan/mapping/mapping.factor Normal file
View File

@ -0,0 +1,148 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.parser classes.tuple
combinators compiler.cfg.instructions
compiler.cfg.linear-scan.allocation.state fry hashtables kernel
locals make namespaces parser sequences sets words ;
IN: compiler.cfg.linear-scan.mapping
SYMBOL: spill-temps
: spill-temp ( reg-class -- n )
spill-temps get [ next-spill-slot ] cache ;
<<
TUPLE: operation from to reg-class ;
SYNTAX: OPERATION:
CREATE-CLASS dup save-location
[ operation { } define-tuple-class ]
[ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ;
>>
OPERATION: register->memory
OPERATION: memory->register
OPERATION: register->register
! This should never come up because of how spill slots are assigned,
! so make it an error.
: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ;
GENERIC: >insn ( operation -- )
M: register->memory >insn
[ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ;
M: memory->register >insn
[ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ;
M: register->register >insn
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
SYMBOL: froms
SYMBOL: tos
SINGLETONS: memory register ;
: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
: from-reg ( operation -- seq )
[ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
: to-reg ( operation -- seq )
[ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
: start? ( operations -- pair )
from-reg tos get key? not ;
: independent-assignment? ( operations -- pair )
to-reg froms get key? not ;
: set-tos/froms ( operations -- )
[ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
[ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
bi ;
:: (trace-chain) ( obj hashtable -- )
obj to-reg froms get at* [
dup ,
obj over hashtable clone [ maybe-set-at ] keep swap
[ (trace-chain) ] [ 2drop ] if
] [
drop
] if ;
: trace-chain ( obj -- seq )
[
dup ,
dup dup associate (trace-chain)
] { } make prune reverse ;
: trace-chains ( seq -- seq' )
[ trace-chain ] map concat ;
ERROR: resolve-error ;
: split-cycle ( operations -- chain spilled-operation )
unclip [
[ set-tos/froms ]
[
[ start? ] find nip
[ resolve-error ] unless* trace-chain
] bi
] dip ;
: break-cycle-n ( operations -- operations' )
split-cycle [
[ from>> ]
[ reg-class>> spill-temp <spill-slot> ]
[ reg-class>> ]
tri \ register->memory boa
] [
[ reg-class>> spill-temp <spill-slot> ]
[ to>> ]
[ reg-class>> ]
tri \ memory->register boa
] bi [ 1array ] bi@ surround ;
: break-cycle ( operations -- operations' )
dup length {
{ 1 [ ] }
[ drop break-cycle-n ]
} case ;
: (group-cycles) ( seq -- )
[
dup set-tos/froms
unclip trace-chain
[ diff ] keep , (group-cycles)
] unless-empty ;
: group-cycles ( seq -- seqs )
[ (group-cycles) ] { } make ;
: remove-dead-mappings ( seq -- seq' )
prune [ [ from-reg ] [ to-reg ] bi = not ] filter ;
: parallel-mappings ( operations -- seq )
[
[ independent-assignment? not ] partition %
[ start? not ] partition
[ trace-chain ] map concat dup %
diff group-cycles [ break-cycle ] map concat %
] { } make remove-dead-mappings ;
: mapping-instructions ( mappings -- insns )
[ { } ] [
[
[ set-tos/froms ] [ parallel-mappings ] bi
[ [ >insn ] each ] { } make
] with-scope
] if-empty ;
: init-mapping ( -- )
H{ } clone spill-temps set ;

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

@ -1,154 +1,7 @@
USING: accessors arrays classes compiler.cfg
compiler.cfg.debugger compiler.cfg.instructions
compiler.cfg.linear-scan.debugger
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.numbering
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 ;
USING: arrays compiler.cfg.linear-scan.resolve kernel
tools.test ;
IN: compiler.cfg.linear-scan.resolve.tests
[ { 1 2 3 4 5 6 } ] [
{ 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 10 } }
T{ _copy { dst 1 } { src 0 } { class int-regs } }
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 20 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _spill { src 2 } { class int-regs } { n 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 10 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _spill { src 0 } { class int-regs } { n 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 10 } }
}
] [
{
T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _copy { dst 2 } { src 0 } { class int-regs } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{ }
] [
{
T{ register->register { from 4 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _spill { src 3 } { class int-regs } { n 4 } }
T{ _reload { dst 2 } { class int-regs } { n 1 } }
}
] [
{
T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } }
T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _copy { dst 2 } { src 0 } { class int-regs } }
T{ _copy { dst 0 } { src 3 } { class int-regs } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _copy { dst 2 } { src 0 } { class int-regs } }
T{ _spill { src 4 } { class int-regs } { n 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 10 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 2 } { src 0 } { class int-regs } }
T{ _copy { dst 9 } { src 1 } { class int-regs } }
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _spill { src 4 } { class int-regs } { n 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 10 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
T{ register->register { from 1 } { to 9 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test

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

@ -1,36 +1,13 @@
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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.allocation.state
compiler.cfg.linear-scan.assignment compiler.cfg.liveness ;
USING: accessors arrays assocs combinators
combinators.short-circuit fry kernel locals
make math sequences
compiler.cfg.instructions
compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.mapping 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 ;
SYNTAX: OPERATION:
CREATE-CLASS dup save-location
[ operation { } define-tuple-class ]
[ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ;
>>
OPERATION: register->memory
OPERATION: memory->register
OPERATION: register->register
! This should never come up because of how spill slots are assigned,
! so make it an error.
: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ;
: add-mapping ( from to reg-class -- )
over spill-slot? [
pick spill-slot?
@ -53,118 +30,6 @@ OPERATION: register->register
[ resolve-value-data-flow ] with with each
] { } make ;
GENERIC: >insn ( operation -- )
M: register->memory >insn
[ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ;
M: memory->register >insn
[ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ;
M: register->register >insn
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
SYMBOL: froms
SYMBOL: tos
SINGLETONS: memory register ;
: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
: from-reg ( operation -- seq )
[ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
: to-reg ( operation -- seq )
[ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
: start? ( operations -- pair )
from-reg tos get key? not ;
: independent-assignment? ( operations -- pair )
to-reg froms get key? not ;
: set-tos/froms ( operations -- )
[ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
[ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
bi ;
:: (trace-chain) ( obj hashtable -- )
obj to-reg froms get at* [
dup ,
obj over hashtable clone [ maybe-set-at ] keep swap
[ (trace-chain) ] [ 2drop ] if
] [
drop
] if ;
: trace-chain ( obj -- seq )
[
dup ,
dup dup associate (trace-chain)
] { } make prune reverse ;
: trace-chains ( seq -- seq' )
[ trace-chain ] map concat ;
ERROR: resolve-error ;
: split-cycle ( operations -- chain spilled-operation )
unclip [
[ set-tos/froms ]
[
[ start? ] find nip
[ resolve-error ] unless* trace-chain
] bi
] dip ;
: break-cycle-n ( operations -- operations' )
split-cycle [
[ from>> ]
[ reg-class>> spill-temp <spill-slot> ]
[ reg-class>> ]
tri \ register->memory boa
] [
[ reg-class>> spill-temp <spill-slot> ]
[ to>> ]
[ reg-class>> ]
tri \ memory->register boa
] bi [ 1array ] bi@ surround ;
: break-cycle ( operations -- operations' )
dup length {
{ 1 [ ] }
[ drop break-cycle-n ]
} case ;
: (group-cycles) ( seq -- )
[
dup set-tos/froms
unclip trace-chain
[ diff ] keep , (group-cycles)
] unless-empty ;
: group-cycles ( seq -- seqs )
[ (group-cycles) ] { } make ;
: remove-dead-mappings ( seq -- seq' )
prune [ [ from-reg ] [ to-reg ] bi = not ] filter ;
: parallel-mappings ( operations -- seq )
[
[ independent-assignment? not ] partition %
[ start? not ] partition
[ trace-chain ] map concat dup %
diff group-cycles [ break-cycle ] map concat %
] { } make remove-dead-mappings ;
: mapping-instructions ( mappings -- insns )
[
[ set-tos/froms ] [ parallel-mappings ] bi
[ [ >insn ] each ] { } make
] with-scope ;
: fork? ( from to -- ? )
{
[ drop successors>> length 1 >= ]
@ -206,5 +71,4 @@ 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 ;

15
basis/compiler/cfg/optimizer/optimizer-tests.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@ USING: accessors arrays compiler.cfg.checker
compiler.cfg.debugger compiler.cfg.def-use
compiler.cfg.instructions fry kernel kernel.private math
math.private sbufs sequences sequences.private sets
slots.private strings tools.test vectors ;
slots.private strings tools.test vectors layouts ;
IN: compiler.cfg.optimizer.tests
! Miscellaneous tests
@ -35,10 +35,11 @@ IN: compiler.cfg.optimizer.tests
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
] each
[ t ]
[
cell 8 = [
[ t ]
[
HEX: 7fff fixnum-bitand 13 fixnum-shift-fast
112 23 fixnum-shift-fast fixnum+fast
] test-mr first instructions>> [ ##add? ] any?
] unit-test
[
1 50 fixnum-shift-fast fixnum+fast
] test-mr first instructions>> [ ##add? ] any?
] unit-test
] when

17
basis/compiler/tree/propagation/info/info.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple
classes.tuple.private kernel accessors math math.intervals
namespaces sequences words combinators
namespaces sequences words combinators byte-arrays strings
arrays compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
@ -66,12 +66,17 @@ DEFER: <literal-info>
[ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
f prefix ;
UNION: fixed-length array byte-array string ;
: init-literal-info ( info -- info )
[-inf,inf] >>interval
dup literal>> class >>class
dup literal>> dup real? [ [a,a] >>interval ] [
[ [-inf,inf] >>interval ] dip
dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
] if ; inline
dup literal>> {
{ [ dup real? ] [ [a,a] >>interval ] }
{ [ dup tuple? ] [ tuple-slot-infos >>slots ] }
{ [ dup fixed-length? ] [ length <literal-info> >>length ] }
[ drop ]
} cond ; inline
: init-value-info ( info -- info )
dup literal?>> [

10
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -331,6 +331,16 @@ cell-bits 32 = [
[ { fixnum } declare dup 10 eq? [ "A" throw ] unless ] final-literals
] unit-test
[ V{ 3 } ] [ [ [ { 1 2 3 } ] [ { 4 5 6 } ] if length ] final-literals ] unit-test
[ V{ 3 } ] [ [ [ B{ 1 2 3 } ] [ B{ 4 5 6 } ] if length ] final-literals ] unit-test
[ V{ 3 } ] [ [ [ "yay" ] [ "hah" ] if length ] final-literals ] unit-test
[ V{ 3 } ] [ [ 3 <byte-array> length ] final-literals ] unit-test
[ V{ 3 } ] [ [ 3 f <string> length ] final-literals ] unit-test
! Slot propagation
TUPLE: prop-test-tuple { x integer } ;

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

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{ \ } ;

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

@ -1,6 +1,6 @@
IN: struct-arrays.tests
USING: struct-arrays tools.test kernel math sequences
alien.syntax alien.c-types destructors libc accessors ;
alien.syntax alien.c-types destructors libc accessors sequences.private ;
C-STRUCT: test-struct
{ "int" "x" }
@ -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 "test-struct" <struct-array> resize length ] unit-test

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

@ -10,6 +10,7 @@ TUPLE: struct-array
{ element-size array-capacity read-only } ;
M: struct-array length length>> ;
M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ;
M: struct-array nth-unsafe
[ element-size>> * ] [ underlying>> ] bi <displaced-alien> ;
@ -20,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"

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

@ -0,0 +1,21 @@
IN: struct-vectors.tests
USING: struct-vectors tools.test alien.c-types alien.syntax
namespaces 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

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

@ -0,0 +1,24 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types 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 byte-length underlying>> byte-length ;
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

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

3
core/hashtables/hashtables-tests.factor
View File

@ -176,3 +176,6 @@ H{ } "x" set
[ 1 ] [ "h" get assoc-size ] unit-test
[ 1 ] [ 2 "h" get at ] unit-test
! Random test case
[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test

2
core/sequences/sequences-docs.factor
View File

@ -1107,7 +1107,7 @@ HELP: replicate
{ "newseq" sequence } }
{ $description "Calls the quotation for every element of the sequence in order. However, the element is not passed to the quotation -- it is dropped, and the quotation produces an element of its own that is collected into a sequence of the same class as the input sequence." }
{ $examples
{ $unchecked-example "USING: prettyprint kernel sequences ;"
{ $unchecked-example "USING: kernel prettyprint random sequences ;"
"5 [ 100 random ] replicate ."
"{ 52 10 45 81 30 }"
}