Merge branch 'master' of git://factorcode.org/git/factor
commit
128c6c8e03
|
@ -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 -- )
|
||||
|
|
|
@ -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 >>
|
|
@ -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 ;
|
||||
|
|
|
@ -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 >>
|
|
@ -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{
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
|
@ -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 -- )
|
||||
{
|
||||
|
|
|
@ -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=
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
|
@ -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 ;
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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?>> [
|
||||
|
|
|
@ -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 } ;
|
||||
|
||||
|
|
|
@ -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) ;
|
||||
|
|
|
@ -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{ \ } ;
|
||||
|
||||
|
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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"
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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,
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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 }"
|
||||
}
|
||||
|
|
Loading…
Reference in New Issue