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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators fry generalizations USING: accessors arrays combinators fry generalizations
io.encodings.ascii io.files io.files.temp io.launcher kernel 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 IN: alien.inline.compiler
SYMBOL: C SYMBOL: C
@ -15,37 +15,59 @@ SYMBOL: C++
{ [ dup windows? ] [ drop ".dll" ] } { [ dup windows? ] [ drop ".dll" ] }
} cond ; } cond ;
: library-path ( str -- str' )
'[
"lib-" % current-vocab name>> %
"-" % _ % library-suffix %
] "" make temp-file ;
: src-suffix ( lang -- str ) : src-suffix ( lang -- str )
{ {
{ C [ ".c" ] } { C [ ".c" ] }
{ C++ [ ".cpp" ] } { C++ [ ".cpp" ] }
} case ; } case ;
: compiler ( lang -- str ) HOOK: compiler os ( lang -- str )
M: word compiler ( lang -- str )
{ {
{ C [ "gcc" ] } { C [ "gcc" ] }
{ C++ [ "g++" ] } { C++ [ "g++" ] }
} case ; } 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 ) : link-command ( in out lang -- descr )
compiler os { compiler-descr link-descr append prepend prepend ;
{ [ dup linux? ]
[ drop { "-shared" "-o" } ] }
{ [ dup macosx? ]
[ drop { "-g" "-prebind" "-dynamiclib" "-o" } ] }
[ name>> "unimplemented for: " prepend throw ]
} cond swap prefix prepend prepend ;
:: compile-to-object ( lang contents name -- ) :: compile-to-object ( lang contents name -- )
name ".o" append temp-file name ".o" append temp-file
contents name lang src-suffix append temp-file contents name lang src-suffix append temp-file
[ ascii set-file-contents ] keep 2array [ ascii set-file-contents ] keep 2array
{ "-fPIC" "-c" "-o" } lang compiler prefix prepend lang compiler-descr { "-fPIC" "-c" "-o" } append prepend
try-process ; try-process ;
:: link-object ( lang args name -- ) :: link-object ( lang args name -- )
args name [ "lib" prepend library-suffix append ] args name [ library-path ]
[ ".o" append ] bi [ temp-file ] bi@ 2array [ ".o" append temp-file ] bi 2array
lang link-command try-process ; lang link-command try-process ;
:: compile-to-library ( lang args contents name -- ) :: 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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.inline.compiler alien.inline.types USING: accessors alien.inline.compiler alien.inline.types
alien.libraries alien.parser arrays assocs effects fry alien.libraries alien.parser arrays assocs effects fry
generalizations grouping io.files io.files.info io.files.temp generalizations grouping io.directories io.files
kernel lexer math math.order math.ranges multiline namespaces io.files.info io.files.temp kernel lexer math math.order
sequences splitting strings system vocabs.loader math.ranges multiline namespaces sequences source-files
vocabs.parser words ; splitting strings system vocabs.loader vocabs.parser words
alien.c-types alien.structs make parser ;
IN: alien.inline IN: alien.inline
<PRIVATE <PRIVATE
@ -41,15 +42,12 @@ SYMBOL: c-strings
: append-function-body ( prototype-str -- str ) : append-function-body ( prototype-str -- str )
" {\n" append parse-here append "\n}\n" append ; " {\n" append parse-here append "\n}\n" append ;
: library-path ( -- str )
"lib" c-library get library-suffix
3array concat temp-file ;
: compile-library? ( -- ? ) : compile-library? ( -- ? )
library-path dup exists? [ c-library get library-path dup exists? [
current-vocab vocab-source-path file get [
[ file-info modified>> ] bi@ <=> +lt+ = path>>
[ file-info modified>> ] bi@ <=> +lt+ =
] [ drop t ] if*
] [ drop t ] if ; ] [ drop t ] if ;
: compile-library ( -- ) : compile-library ( -- )
@ -66,7 +64,7 @@ PRIVATE>
: compile-c-library ( -- ) : compile-c-library ( -- )
compile-library? [ compile-library ] when 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 -- ) : define-c-function ( function types effect -- )
[ factor-function define-declared ] 3keep prototype-string [ factor-function define-declared ] 3keep prototype-string
@ -89,6 +87,25 @@ PRIVATE>
: define-c-include ( str -- ) : define-c-include ( str -- )
"#include " prepend c-strings get push ; "#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: C-LIBRARY: scan define-c-library ;
SYNTAX: COMPILE-AS-C++ t library-is-c++ set ; SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
@ -104,4 +121,14 @@ SYNTAX: C-INCLUDE: scan define-c-include ;
SYNTAX: C-FUNCTION: SYNTAX: C-FUNCTION:
function-types-effect define-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: ;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." } ; { $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
HELP: <bit-vector> HELP: <bit-vector>
{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } } { $values { "capacity" "a positive integer specifying initial capacity" } { "vector" bit-vector } }
{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ; { $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;
HELP: >bit-vector HELP: >bit-vector
{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } } { $values { "seq" "a sequence" } { "vector" bit-vector } }
{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ; { $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
HELP: ?V{ HELP: ?V{

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

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

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 -- ? ) : no-free-registers? ( result -- ? )
second 0 = ; inline 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 -- ) : 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 -- ) : assign-register ( new -- )
dup coalesce? [ coalesce ] [ dup coalesce? [ coalesce ] [
dup register-status { dup register-status {
{ [ dup no-free-registers? ] [ drop assign-blocked-register ] } { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
{ [ 2dup register-available? ] [ register-available ] } { [ 2dup register-available? ] [ register-available ] }
[ register-partially-available ] ! [ register-partially-available ]
[ drop assign-blocked-register ]
} cond } cond
] if ; ] if ;

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

@ -38,7 +38,7 @@ ERROR: bad-live-ranges interval ;
} 2cleave ; } 2cleave ;
: assign-spill ( live-interval -- ) : 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 -- ) : assign-reload ( live-interval -- )
dup vreg>> assign-spill-slot >>reload-from drop ; dup vreg>> assign-spill-slot >>reload-from drop ;
@ -80,10 +80,12 @@ ERROR: bad-live-ranges interval ;
[ add-unhandled ] [ add-unhandled ]
} cleave ; } cleave ;
: split-intersecting? ( live-interval new reg -- ? ) : spill-live-out? ( live-interval n -- ? ) [ uses>> last ] dip < ;
{ [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ;
: 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 ] [ trim-before-ranges ]
[ compute-start/end ] [ compute-start/end ]
@ -91,7 +93,13 @@ ERROR: bad-live-ranges interval ;
[ add-handled ] [ add-handled ]
} cleave ; } 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 ] [ trim-after-ranges ]
[ compute-start/end ] [ compute-start/end ]
@ -99,40 +107,48 @@ ERROR: bad-live-ranges interval ;
[ add-unhandled ] [ add-unhandled ]
} cleave ; } cleave ;
: (split-intersecting) ( live-interval new -- ) : spill ( live-interval n -- )
start>> { {
{ [ 2dup [ uses>> last ] dip < ] [ drop split-live-out ] } { [ 2dup spill-live-out? ] [ drop spill-live-out ] }
{ [ 2dup [ uses>> first ] dip > ] [ drop split-live-in ] } { [ 2dup spill-live-in? ] [ drop spill-live-in ] }
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ]
} cond ; } cond ;
: (split-intersecting-active) ( active new -- ) :: spill-intersecting-active ( new reg -- )
[ drop delete-active ] ! If there is an active interval using 'reg' (there should be at
[ (split-intersecting) ] 2bi ; ! 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 -- ) :: spill-intersecting-inactive ( new reg -- )
[ [ vreg>> active-intervals-for ] keep ] dip ! Any inactive intervals using 'reg' are split and spilled
[ '[ _ _ split-intersecting? ] filter ] 2keep drop ! and removed from the inactive set.
'[ _ (split-intersecting-active) ] each ; 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 -- ) : spill-intersecting ( new reg -- )
[ drop delete-inactive ] ! Split and spill all active and inactive intervals
[ (split-intersecting) ] 2bi ; ! which intersect 'new' and use 'reg'.
[ spill-intersecting-active ]
: split-intersecting-inactive ( new reg -- ) [ spill-intersecting-inactive ]
[ [ 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 ; 2bi ;
: spill-available ( new pair -- ) : 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 -- ) : 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 [ second 1 - split-and-spill add-unhandled ] keep
spill-available ; 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 ; after split-after ;
HINTS: split-interval live-interval object ; 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.liveness
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.linear-scan.mapping
compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.live-intervals ;
@ -42,16 +43,11 @@ SYMBOL: register-live-outs
H{ } clone register-live-outs set H{ } clone register-live-outs set
init-unhandled ; init-unhandled ;
: insert-spill ( live-interval -- )
{
[ reg>> ]
[ vreg>> reg-class>> ]
[ spill-to>> ]
[ end>> ]
} cleave f swap \ _spill boa , ;
: handle-spill ( live-interval -- ) : 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' ) : first-split ( live-interval -- live-interval' )
dup split-before>> [ first-split ] [ ] ?if ; dup split-before>> [ first-split ] [ ] ?if ;
@ -59,22 +55,19 @@ SYMBOL: register-live-outs
: next-interval ( live-interval -- live-interval' ) : next-interval ( live-interval -- live-interval' )
split-next>> first-split ; 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 -- ) : 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 -- ) : expire-old-intervals ( n -- )
[ pending-intervals get ] dip '[ [
dup end>> _ < [ pending-intervals get ] dip '[
[ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if dup end>> _ <
] filter-here ; [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
] filter-here
] { } make mapping-instructions % ;
: insert-reload ( live-interval -- ) : 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 IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors locals kernel fry arrays splitting namespaces math accessors vectors locals
math.order grouping strings strings.private math.order grouping strings strings.private classes
cpu.architecture cpu.architecture
compiler.cfg compiler.cfg
compiler.cfg.optimizer compiler.cfg.optimizer
@ -153,56 +153,6 @@ check-numbering? on
} 10 split-for-spill [ f >>split-next ] bi@ } 10 split-for-spill [ f >>split-next ] bi@
] unit-test ] 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 T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
@ -225,7 +175,7 @@ check-numbering? on
{ end 10 } { end 10 }
{ uses V{ 0 1 4 5 10 } } { uses V{ 0 1 4 5 10 } }
{ ranges V{ T{ live-range f 0 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 ] unit-test
[ [
@ -1847,8 +1797,6 @@ test-diamond
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test [ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
USING: classes ;
[ ] [ [ ] [
1 get instructions>> first regs>> V int-regs 0 swap at 1 get instructions>> first regs>> V int-regs 0 swap at
2 get instructions>> first regs>> V int-regs 1 swap at assert= 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
compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.assignment 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 IN: compiler.cfg.linear-scan
! References: ! References:
@ -36,6 +37,7 @@ IN: compiler.cfg.linear-scan
: linear-scan ( cfg -- cfg' ) : linear-scan ( cfg -- cfg' )
[ [
init-mapping
dup reverse-post-order machine-registers (linear-scan) dup reverse-post-order machine-registers (linear-scan)
spill-counts get >>spill-counts spill-counts get >>spill-counts
] with-scope ; ] 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 USING: arrays compiler.cfg.linear-scan.resolve kernel
compiler.cfg.debugger compiler.cfg.instructions tools.test ;
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 ;
IN: compiler.cfg.linear-scan.resolve.tests IN: compiler.cfg.linear-scan.resolve.tests
[ { 1 2 3 4 5 6 } ] [ [ { 1 2 3 4 5 6 } ] [
{ 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array { 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
] unit-test ] unit-test
H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
H{ } clone spill-temps set
[
{
T{ _copy { dst 5 } { src 4 } { class int-regs } }
T{ _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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.parser classes.tuple USING: accessors arrays assocs combinators
combinators combinators.short-circuit fry hashtables kernel locals combinators.short-circuit fry kernel locals
make math math.order namespaces sequences sets words parser make math sequences
compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state compiler.cfg.instructions
compiler.cfg.linear-scan.assignment compiler.cfg.liveness ; compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.mapping compiler.cfg.liveness ;
IN: compiler.cfg.linear-scan.resolve IN: compiler.cfg.linear-scan.resolve
SYMBOL: spill-temps
: spill-temp ( reg-class -- n )
spill-temps get [ next-spill-slot ] cache ;
<<
TUPLE: operation from to reg-class ;
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 -- ) : add-mapping ( from to reg-class -- )
over spill-slot? [ over spill-slot? [
pick spill-slot? pick spill-slot?
@ -53,118 +30,6 @@ OPERATION: register->register
[ resolve-value-data-flow ] with with each [ resolve-value-data-flow ] with with each
] { } make ; ] { } 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 -- ? ) : fork? ( from to -- ? )
{ {
[ drop successors>> length 1 >= ] [ drop successors>> length 1 >= ]
@ -206,5 +71,4 @@ ERROR: resolve-error ;
dup successors>> [ resolve-edge-data-flow ] with each ; dup successors>> [ resolve-edge-data-flow ] with each ;
: resolve-data-flow ( rpo -- ) : resolve-data-flow ( rpo -- )
H{ } clone spill-temps set
[ resolve-block-data-flow ] each ; [ resolve-block-data-flow ] each ;

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.debugger compiler.cfg.def-use
compiler.cfg.instructions fry kernel kernel.private math compiler.cfg.instructions fry kernel kernel.private math
math.private sbufs sequences sequences.private sets 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 IN: compiler.cfg.optimizer.tests
! Miscellaneous tests ! Miscellaneous tests
@ -35,10 +35,11 @@ IN: compiler.cfg.optimizer.tests
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
] each ] each
[ t ] cell 8 = [
[ [ t ]
[ [
HEX: 7fff fixnum-bitand 13 fixnum-shift-fast [
112 23 fixnum-shift-fast fixnum+fast 1 50 fixnum-shift-fast fixnum+fast
] test-mr first instructions>> [ ##add? ] any? ] test-mr first instructions>> [ ##add? ] any?
] unit-test ] 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. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple USING: assocs classes classes.algebra classes.tuple
classes.tuple.private kernel accessors math math.intervals classes.tuple.private kernel accessors math math.intervals
namespaces sequences words combinators namespaces sequences words combinators byte-arrays strings
arrays compiler.tree.propagation.copy ; arrays compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info IN: compiler.tree.propagation.info
@ -66,12 +66,17 @@ DEFER: <literal-info>
[ read-only>> [ <literal-info> ] [ drop f ] if ] 2map [ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
f prefix ; f prefix ;
UNION: fixed-length array byte-array string ;
: init-literal-info ( info -- info ) : init-literal-info ( info -- info )
[-inf,inf] >>interval
dup literal>> class >>class dup literal>> class >>class
dup literal>> dup real? [ [a,a] >>interval ] [ dup literal>> {
[ [-inf,inf] >>interval ] dip { [ dup real? ] [ [a,a] >>interval ] }
dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if { [ dup tuple? ] [ tuple-slot-infos >>slots ] }
] if ; inline { [ dup fixed-length? ] [ length <literal-info> >>length ] }
[ drop ]
} cond ; inline
: init-value-info ( info -- info ) : init-value-info ( info -- info )
dup literal?>> [ 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 [ { fixnum } declare dup 10 eq? [ "A" throw ] unless ] final-literals
] unit-test ] 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 ! Slot propagation
TUPLE: prop-test-tuple { x integer } ; 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: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ;
SYNTAX: DEFERS [ current-vocab create ] (INTERPOLATE) ;
SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ; SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;

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

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

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

@ -1,6 +1,6 @@
IN: struct-arrays.tests IN: struct-arrays.tests
USING: struct-arrays tools.test kernel math sequences 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 C-STRUCT: test-struct
{ "int" "x" } { "int" "x" }
@ -36,3 +36,5 @@ C-STRUCT: test-struct
&free drop &free drop
] with-destructors ] 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 } ; { element-size array-capacity read-only } ;
M: struct-array length length>> ; M: struct-array length length>> ;
M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ;
M: struct-array nth-unsafe M: struct-array nth-unsafe
[ element-size>> * ] [ underlying>> ] bi <displaced-alien> ; [ element-size>> * ] [ underlying>> ] bi <displaced-alien> ;
@ -20,6 +21,10 @@ M: struct-array set-nth-unsafe
M: struct-array new-sequence M: struct-array new-sequence
element-size>> [ * <byte-array> ] 2keep struct-array boa ; inline element-size>> [ * <byte-array> ] 2keep struct-array boa ; inline
M: struct-array resize ( n seq -- newseq )
[ [ element-size>> * ] [ underlying>> ] bi resize ] [ element-size>> ] 2bi
struct-array boa ;
: <struct-array> ( length c-type -- struct-array ) : <struct-array> ( length c-type -- struct-array )
heap-size [ * <byte-array> ] 2keep struct-array boa ; inline heap-size [ * <byte-array> ] 2keep struct-array boa ; inline

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

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

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? M: byte-vector equal?
over byte-vector? [ sequence= ] [ 2drop f ] if ; over byte-vector? [ sequence= ] [ 2drop f ] if ;
M: byte-vector contract 2drop ;
M: byte-array like M: byte-array like
#! If we have an byte-array, we're done. #! If we have an byte-array, we're done.
#! If we have a byte-vector, and it's at full capacity, #! If we have a byte-vector, and it's at full capacity,

8
core/growable/growable.factor
View File

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

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

@ -176,3 +176,6 @@ H{ } "x" set
[ 1 ] [ "h" get assoc-size ] unit-test [ 1 ] [ "h" get assoc-size ] unit-test
[ 1 ] [ 2 "h" get at ] 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 } } { "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." } { $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 { $examples
{ $unchecked-example "USING: prettyprint kernel sequences ;" { $unchecked-example "USING: kernel prettyprint random sequences ;"
"5 [ 100 random ] replicate ." "5 [ 100 random ] replicate ."
"{ 52 10 45 81 30 }" "{ 52 10 45 81 30 }"
} }