Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
992ab4e677
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces sequences math math.order kernel assocs
|
||||
accessors vectors fry heaps cpu.architecture combinators
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.linear-scan.live-intervals ;
|
||||
accessors vectors fry heaps cpu.architecture sorting locals
|
||||
combinators compiler.cfg.registers
|
||||
compiler.cfg.linear-scan.live-intervals hints ;
|
||||
IN: compiler.cfg.linear-scan.allocation
|
||||
|
||||
! Mapping from register classes to sequences of machine registers
|
||||
|
|
@ -27,13 +27,61 @@ SYMBOL: active-intervals
|
|||
: delete-active ( live-interval -- )
|
||||
dup vreg>> active-intervals-for delq ;
|
||||
|
||||
: expire-old-intervals ( n -- )
|
||||
active-intervals swap '[
|
||||
[
|
||||
[ end>> _ < ] partition
|
||||
[ [ deallocate-register ] each ] dip
|
||||
] assoc-map
|
||||
] change ;
|
||||
! Vector of inactive live intervals
|
||||
SYMBOL: inactive-intervals
|
||||
|
||||
: inactive-intervals-for ( vreg -- seq )
|
||||
reg-class>> inactive-intervals get at ;
|
||||
|
||||
: add-inactive ( live-interval -- )
|
||||
dup vreg>> inactive-intervals-for push ;
|
||||
|
||||
! Vector of handled live intervals
|
||||
SYMBOL: handled-intervals
|
||||
|
||||
: add-handled ( live-interval -- )
|
||||
handled-intervals get push ;
|
||||
|
||||
: finished? ( n live-interval -- ? ) end>> swap < ;
|
||||
|
||||
: finish ( n live-interval -- keep? )
|
||||
nip [ deallocate-register ] [ add-handled ] bi f ;
|
||||
|
||||
: activate ( n live-interval -- keep? )
|
||||
nip add-active f ;
|
||||
|
||||
: deactivate ( n live-interval -- keep? )
|
||||
nip add-inactive f ;
|
||||
|
||||
: don't-change ( n live-interval -- keep? ) 2drop t ;
|
||||
|
||||
! Moving intervals between active and inactive sets
|
||||
: process-intervals ( n symbol quots -- )
|
||||
! symbol stores an alist mapping register classes to vectors
|
||||
[ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
|
||||
|
||||
: covers? ( insn# live-interval -- ? )
|
||||
ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
|
||||
|
||||
: deactivate-intervals ( n -- )
|
||||
! Any active intervals which have ended are moved to handled
|
||||
! Any active intervals which cover the current position
|
||||
! are moved to inactive
|
||||
active-intervals {
|
||||
{ [ 2dup finished? ] [ finish ] }
|
||||
{ [ 2dup covers? not ] [ deactivate ] }
|
||||
[ don't-change ]
|
||||
} process-intervals ;
|
||||
|
||||
: activate-intervals ( n -- )
|
||||
! Any inactive intervals which have ended are moved to handled
|
||||
! Any inactive intervals which do not cover the current position
|
||||
! are moved to active
|
||||
inactive-intervals {
|
||||
{ [ 2dup finished? ] [ finish ] }
|
||||
{ [ 2dup covers? ] [ activate ] }
|
||||
[ don't-change ]
|
||||
} process-intervals ;
|
||||
|
||||
! Minheap of live intervals which still need a register allocation
|
||||
SYMBOL: unhandled-intervals
|
||||
|
|
@ -66,29 +114,64 @@ SYMBOL: progress
|
|||
|
||||
: coalesce ( live-interval -- )
|
||||
dup copy-from>> active-interval
|
||||
[ [ add-active ] [ delete-active ] bi* ]
|
||||
[ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
|
||||
[ reg>> >>reg drop ]
|
||||
2bi ;
|
||||
|
||||
! Splitting
|
||||
: find-use ( live-interval n quot -- i elt )
|
||||
[ uses>> ] 2dip curry find ; inline
|
||||
: split-range ( live-range n -- before after )
|
||||
[ [ from>> ] dip <live-range> ]
|
||||
[ 1 + swap to>> <live-range> ]
|
||||
2bi ;
|
||||
|
||||
: split-before ( live-interval i -- before )
|
||||
[ clone dup uses>> ] dip
|
||||
[ head >>uses ] [ 1- swap nth >>end ] 2bi ;
|
||||
: split-last-range? ( last n -- ? )
|
||||
swap to>> <= ;
|
||||
|
||||
: split-after ( live-interval i -- after )
|
||||
[ clone dup uses>> ] dip
|
||||
[ tail >>uses ] [ swap nth >>start ] 2bi
|
||||
f >>reg f >>copy-from ;
|
||||
: split-last-range ( before after last n -- before' after' )
|
||||
split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
|
||||
|
||||
: split-interval ( live-interval n -- before after )
|
||||
[ drop ] [ [ > ] find-use drop ] 2bi
|
||||
[ split-before ] [ split-after ] 2bi ;
|
||||
: split-ranges ( live-ranges n -- before after )
|
||||
[ '[ from>> _ <= ] partition ]
|
||||
[
|
||||
pick empty? [ drop ] [
|
||||
[ over last ] dip 2dup split-last-range?
|
||||
[ split-last-range ] [ 2drop ] if
|
||||
] if
|
||||
] bi ;
|
||||
|
||||
: split-uses ( uses n -- before after )
|
||||
'[ _ <= ] partition ;
|
||||
|
||||
: record-split ( live-interval before after -- )
|
||||
[ >>split-before ] [ >>split-after ] bi* drop ;
|
||||
[ >>split-before ] [ >>split-after ] bi* drop ; inline
|
||||
|
||||
: check-split ( live-interval -- )
|
||||
[ end>> ] [ start>> ] bi - 0 =
|
||||
[ "BUG: splitting atomic interval" throw ] when ; inline
|
||||
|
||||
: split-before ( before -- before' )
|
||||
[ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
|
||||
[ compute-start/end ]
|
||||
[ ]
|
||||
tri ; inline
|
||||
|
||||
: split-after ( after -- after' )
|
||||
[ [ ranges>> first ] [ uses>> first ] bi >>from drop ]
|
||||
[ compute-start/end ]
|
||||
[ ]
|
||||
tri ; inline
|
||||
|
||||
:: split-interval ( live-interval n -- before after )
|
||||
live-interval check-split
|
||||
live-interval clone :> before
|
||||
live-interval clone f >>copy-from f >>reg :> after
|
||||
live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi*
|
||||
live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi*
|
||||
live-interval before after record-split
|
||||
before split-before
|
||||
after split-after ;
|
||||
|
||||
HINTS: split-interval live-interval object ;
|
||||
|
||||
! Spilling
|
||||
SYMBOL: spill-counts
|
||||
|
|
@ -96,6 +179,9 @@ SYMBOL: spill-counts
|
|||
: next-spill-location ( reg-class -- n )
|
||||
spill-counts get [ dup 1+ ] change-at ;
|
||||
|
||||
: find-use ( live-interval n quot -- i elt )
|
||||
[ uses>> ] 2dip curry find ; inline
|
||||
|
||||
: interval-to-spill ( active-intervals current -- live-interval )
|
||||
#! We spill the interval with the most distant use location.
|
||||
start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
|
||||
|
|
@ -108,8 +194,7 @@ SYMBOL: spill-counts
|
|||
[ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
|
||||
|
||||
: split-and-spill ( new existing -- before after )
|
||||
dup rot start>> split-interval
|
||||
[ record-split ] [ assign-spill ] 2bi ;
|
||||
swap start>> split-interval assign-spill ;
|
||||
|
||||
: reuse-register ( new existing -- )
|
||||
reg>> >>reg add-active ;
|
||||
|
|
@ -121,7 +206,7 @@ SYMBOL: spill-counts
|
|||
#! of the existing interval again.
|
||||
[ reuse-register ]
|
||||
[ nip delete-active ]
|
||||
[ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ;
|
||||
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
|
||||
|
||||
: spill-new ( new existing -- )
|
||||
#! Our new interval will be used after the active interval
|
||||
|
|
@ -141,37 +226,78 @@ SYMBOL: spill-counts
|
|||
: assign-free-register ( new registers -- )
|
||||
pop >>reg add-active ;
|
||||
|
||||
: assign-register ( new -- )
|
||||
dup coalesce? [
|
||||
coalesce
|
||||
: next-intersection ( new inactive -- n )
|
||||
2drop 0 ;
|
||||
|
||||
: intersecting-inactive ( new -- live-intervals )
|
||||
dup vreg>> inactive-intervals-for
|
||||
[ tuck next-intersection ] with { } map>assoc ;
|
||||
|
||||
: fits-in-hole ( new pair -- )
|
||||
first reuse-register ;
|
||||
|
||||
: split-before-use ( new pair -- before after )
|
||||
! Find optimal split position
|
||||
second split-interval ;
|
||||
|
||||
: assign-inactive-register ( new live-intervals -- )
|
||||
! If there is an interval which is inactive for the entire lifetime
|
||||
! if the new interval, reuse its vreg. Otherwise, split new so that
|
||||
! the first half fits.
|
||||
sort-values last
|
||||
2dup [ end>> ] [ second ] bi* < [
|
||||
fits-in-hole
|
||||
] [
|
||||
dup vreg>> free-registers-for
|
||||
[ assign-blocked-register ]
|
||||
[ assign-free-register ]
|
||||
[ split-before-use ] keep
|
||||
'[ _ fits-in-hole ] [ add-unhandled ] bi*
|
||||
] if ;
|
||||
|
||||
: assign-register ( new -- )
|
||||
dup coalesce? [ coalesce ] [
|
||||
dup vreg>> free-registers-for [
|
||||
dup intersecting-inactive
|
||||
[ assign-blocked-register ]
|
||||
[ assign-inactive-register ]
|
||||
if-empty
|
||||
] [ assign-free-register ]
|
||||
if-empty
|
||||
] if ;
|
||||
|
||||
! Main loop
|
||||
: reg-classes ( -- seq ) { int-regs double-float-regs } ; inline
|
||||
|
||||
: reg-class-assoc ( quot -- assoc )
|
||||
[ reg-classes ] dip { } map>assoc ; inline
|
||||
|
||||
: init-allocator ( registers -- )
|
||||
<min-heap> unhandled-intervals set
|
||||
[ reverse >vector ] assoc-map free-registers set
|
||||
reg-classes [ 0 ] { } map>assoc spill-counts set
|
||||
reg-classes [ V{ } clone ] { } map>assoc active-intervals set
|
||||
[ 0 ] reg-class-assoc spill-counts set
|
||||
<min-heap> unhandled-intervals set
|
||||
[ V{ } clone ] reg-class-assoc active-intervals set
|
||||
[ V{ } clone ] reg-class-assoc inactive-intervals set
|
||||
V{ } clone handled-intervals set
|
||||
-1 progress set ;
|
||||
|
||||
: handle-interval ( live-interval -- )
|
||||
[ start>> progress set ]
|
||||
[ start>> expire-old-intervals ]
|
||||
[ assign-register ]
|
||||
tri ;
|
||||
[
|
||||
start>>
|
||||
[ progress set ]
|
||||
[ deactivate-intervals ]
|
||||
[ activate-intervals ] tri
|
||||
] [ assign-register ] bi ;
|
||||
|
||||
: (allocate-registers) ( -- )
|
||||
unhandled-intervals get [ handle-interval ] slurp-heap ;
|
||||
|
||||
: finish-allocation ( -- )
|
||||
! Sanity check: all live intervals should've been processed
|
||||
active-intervals inactive-intervals
|
||||
[ get values [ handled-intervals get push-all ] each ] bi@ ;
|
||||
|
||||
: allocate-registers ( live-intervals machine-registers -- live-intervals )
|
||||
#! This modifies the input live-intervals.
|
||||
init-allocator
|
||||
dup init-unhandled
|
||||
(allocate-registers) ;
|
||||
init-unhandled
|
||||
(allocate-registers)
|
||||
finish-allocation
|
||||
handled-intervals get ;
|
||||
|
|
|
|||
|
|
@ -25,12 +25,7 @@ TUPLE: active-intervals seq ;
|
|||
SYMBOL: unhandled-intervals
|
||||
|
||||
: add-unhandled ( live-interval -- )
|
||||
dup split-before>> [
|
||||
[ split-before>> ] [ split-after>> ] bi
|
||||
[ add-unhandled ] bi@
|
||||
] [
|
||||
dup start>> unhandled-intervals get heap-push
|
||||
] if ;
|
||||
dup start>> unhandled-intervals get heap-push ;
|
||||
|
||||
: init-unhandled ( live-intervals -- )
|
||||
[ add-unhandled ] each ;
|
||||
|
|
|
|||
|
|
@ -12,6 +12,60 @@ compiler.cfg.linear-scan.live-intervals
|
|||
compiler.cfg.linear-scan.allocation
|
||||
compiler.cfg.linear-scan.debugger ;
|
||||
|
||||
[
|
||||
{ T{ live-range f 1 10 } T{ live-range f 15 15 } }
|
||||
{ T{ live-range f 16 20 } }
|
||||
] [
|
||||
{
|
||||
T{ live-range f 1 10 }
|
||||
T{ live-range f 15 20 }
|
||||
} 15 split-ranges
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ T{ live-range f 1 10 } T{ live-range f 15 16 } }
|
||||
{ T{ live-range f 17 20 } }
|
||||
] [
|
||||
{
|
||||
T{ live-range f 1 10 }
|
||||
T{ live-range f 15 20 }
|
||||
} 16 split-ranges
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ T{ live-range f 1 10 } }
|
||||
{ T{ live-range f 15 20 } }
|
||||
] [
|
||||
{
|
||||
T{ live-range f 1 10 }
|
||||
T{ live-range f 15 20 }
|
||||
} 12 split-ranges
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ T{ live-range f 1 10 } T{ live-range f 15 17 } }
|
||||
{ T{ live-range f 18 20 } }
|
||||
] [
|
||||
{
|
||||
T{ live-range f 1 10 }
|
||||
T{ live-range f 15 20 }
|
||||
} 17 split-ranges
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ }
|
||||
{ T{ live-range f 1 10 } }
|
||||
] [
|
||||
{ T{ live-range f 1 10 } } 0 split-ranges
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ T{ live-range f 0 0 } }
|
||||
{ T{ live-range f 1 5 } }
|
||||
] [
|
||||
{ T{ live-range f 0 5 } } 0 split-ranges
|
||||
] unit-test
|
||||
|
||||
[ 7 ] [
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
|
||||
|
|
@ -44,23 +98,26 @@ compiler.cfg.linear-scan.debugger ;
|
|||
|
||||
[
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 1 }
|
||||
{ uses V{ 0 1 } }
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 1 }
|
||||
{ uses V{ 0 1 } }
|
||||
{ ranges V{ T{ live-range f 0 1 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 5 }
|
||||
{ end 5 }
|
||||
{ uses V{ 5 } }
|
||||
{ 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 } }
|
||||
{ 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 } } }
|
||||
} 2 split-interval
|
||||
] unit-test
|
||||
|
||||
|
|
@ -70,12 +127,14 @@ compiler.cfg.linear-scan.debugger ;
|
|||
{ start 0 }
|
||||
{ end 0 }
|
||||
{ uses V{ 0 } }
|
||||
{ ranges V{ T{ live-range f 0 0 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 1 }
|
||||
{ end 5 }
|
||||
{ uses V{ 1 5 } }
|
||||
{ ranges V{ T{ live-range f 1 5 } } }
|
||||
}
|
||||
] [
|
||||
T{ live-interval
|
||||
|
|
@ -83,6 +142,7 @@ compiler.cfg.linear-scan.debugger ;
|
|||
{ start 0 }
|
||||
{ end 5 }
|
||||
{ uses V{ 0 1 5 } }
|
||||
{ ranges V{ T{ live-range f 0 5 } } }
|
||||
} 0 split-interval
|
||||
] unit-test
|
||||
|
||||
|
|
@ -173,7 +233,13 @@ compiler.cfg.linear-scan.debugger ;
|
|||
|
||||
[ ] [
|
||||
{
|
||||
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
|
||||
{ start 0 }
|
||||
{ end 100 }
|
||||
{ uses V{ 0 100 } }
|
||||
{ ranges V{ T{ live-range f 0 100 } } }
|
||||
}
|
||||
}
|
||||
H{ { int-regs { "A" } } }
|
||||
check-linear-scan
|
||||
|
|
@ -181,8 +247,20 @@ compiler.cfg.linear-scan.debugger ;
|
|||
|
||||
[ ] [
|
||||
{
|
||||
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 10 } { uses V{ 0 10 } } }
|
||||
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } }
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
|
||||
{ start 0 }
|
||||
{ end 10 }
|
||||
{ uses V{ 0 10 } }
|
||||
{ ranges V{ T{ live-range f 0 10 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
|
||||
{ start 11 }
|
||||
{ end 20 }
|
||||
{ uses V{ 11 20 } }
|
||||
{ ranges V{ T{ live-range f 11 20 } } }
|
||||
}
|
||||
}
|
||||
H{ { int-regs { "A" } } }
|
||||
check-linear-scan
|
||||
|
|
@ -190,8 +268,20 @@ compiler.cfg.linear-scan.debugger ;
|
|||
|
||||
[ ] [
|
||||
{
|
||||
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
|
||||
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } }
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
|
||||
{ start 0 }
|
||||
{ end 100 }
|
||||
{ uses V{ 0 100 } }
|
||||
{ ranges V{ T{ live-range f 0 100 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
|
||||
{ start 30 }
|
||||
{ end 60 }
|
||||
{ uses V{ 30 60 } }
|
||||
{ ranges V{ T{ live-range f 30 60 } } }
|
||||
}
|
||||
}
|
||||
H{ { int-regs { "A" } } }
|
||||
check-linear-scan
|
||||
|
|
@ -199,8 +289,20 @@ compiler.cfg.linear-scan.debugger ;
|
|||
|
||||
[ ] [
|
||||
{
|
||||
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
|
||||
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } }
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
|
||||
{ start 0 }
|
||||
{ end 100 }
|
||||
{ uses V{ 0 100 } }
|
||||
{ ranges V{ T{ live-range f 0 100 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
|
||||
{ start 30 }
|
||||
{ end 200 }
|
||||
{ uses V{ 30 200 } }
|
||||
{ ranges V{ T{ live-range f 30 200 } } }
|
||||
}
|
||||
}
|
||||
H{ { int-regs { "A" } } }
|
||||
check-linear-scan
|
||||
|
|
@ -208,8 +310,20 @@ compiler.cfg.linear-scan.debugger ;
|
|||
|
||||
[
|
||||
{
|
||||
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
|
||||
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 100 } } }
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
|
||||
{ start 0 }
|
||||
{ end 100 }
|
||||
{ uses V{ 0 100 } }
|
||||
{ ranges V{ T{ live-range f 0 100 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
|
||||
{ start 30 }
|
||||
{ end 100 }
|
||||
{ uses V{ 30 100 } }
|
||||
{ ranges V{ T{ live-range f 30 100 } } }
|
||||
}
|
||||
}
|
||||
H{ { int-regs { "A" } } }
|
||||
check-linear-scan
|
||||
|
|
@ -272,31 +386,10 @@ USING: math.private compiler.cfg.debugger ;
|
|||
test-cfg first optimize-cfg linear-scan drop
|
||||
] unit-test
|
||||
|
||||
[ 0 1 ] [
|
||||
{
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 5 }
|
||||
{ uses V{ 0 1 5 } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
|
||||
{ start 3 }
|
||||
{ end 4 }
|
||||
{ uses V{ 3 4 } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 3 } } }
|
||||
{ start 2 }
|
||||
{ end 6 }
|
||||
{ uses V{ 2 4 6 } }
|
||||
}
|
||||
} [ clone ] map
|
||||
H{ { int-regs { "A" "B" } } }
|
||||
allocate-registers
|
||||
first split-before>> [ start>> ] [ end>> ] bi
|
||||
] unit-test
|
||||
: fake-live-ranges ( seq -- seq' )
|
||||
[
|
||||
clone dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
|
||||
] map ;
|
||||
|
||||
! Coalescing interacted badly with splitting
|
||||
[ ] [
|
||||
|
|
@ -345,7 +438,7 @@ USING: math.private compiler.cfg.debugger ;
|
|||
{ end 10 }
|
||||
{ uses V{ 9 10 } }
|
||||
}
|
||||
}
|
||||
} fake-live-ranges
|
||||
{ { int-regs { 0 1 2 3 } } }
|
||||
allocate-registers drop
|
||||
] unit-test
|
||||
|
|
@ -1100,7 +1193,7 @@ USING: math.private compiler.cfg.debugger ;
|
|||
{ end 109 }
|
||||
{ uses V{ 103 109 } }
|
||||
}
|
||||
}
|
||||
} fake-live-ranges
|
||||
{ { int-regs { 0 1 2 3 4 } } }
|
||||
allocate-registers drop
|
||||
] unit-test
|
||||
|
|
@ -1193,7 +1286,7 @@ USING: math.private compiler.cfg.debugger ;
|
|||
{ end 92 }
|
||||
{ uses V{ 42 45 78 80 92 } }
|
||||
}
|
||||
}
|
||||
} fake-live-ranges
|
||||
{ { int-regs { 0 1 2 3 } } }
|
||||
allocate-registers drop
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces kernel assocs accessors sequences math math.order fry
|
||||
compiler.cfg.instructions compiler.cfg.registers
|
||||
binary-search compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
|
||||
IN: compiler.cfg.linear-scan.live-intervals
|
||||
|
||||
|
|
@ -109,6 +109,7 @@ M: ##copy-float compute-live-intervals*
|
|||
|
||||
: compute-start/end ( live-interval -- )
|
||||
dup ranges>> [ first from>> ] [ last to>> ] bi
|
||||
2dup > [ "BUG: start > end" throw ] when
|
||||
[ >>start ] [ >>end ] bi* drop ;
|
||||
|
||||
: finish-live-intervals ( live-intervals -- )
|
||||
|
|
|
|||
|
|
@ -20,7 +20,6 @@ SYMBOL: AAPL
|
|||
} 1&&
|
||||
] unit-test
|
||||
|
||||
|
||||
TUPLE: ct1 a ;
|
||||
TUPLE: ct2 < ct1 b ;
|
||||
TUPLE: ct3 < ct2 c ;
|
||||
|
|
@ -41,7 +40,20 @@ CONSTRUCTOR: ct4 ( a b c d -- obj )
|
|||
initialize-ct3
|
||||
[ 1 + ] change-a ;
|
||||
|
||||
[ 1 ] [ 0 <ct1> a>> ] unit-test
|
||||
[ 1001 ] [ 1000 <ct1> a>> ] unit-test
|
||||
[ 2 ] [ 0 0 <ct2> a>> ] unit-test
|
||||
[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
|
||||
[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test
|
||||
|
||||
|
||||
TUPLE: rofl a b c ;
|
||||
CONSTRUCTOR: rofl ( b c a -- obj ) ;
|
||||
|
||||
[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 <rofl> ] unit-test
|
||||
|
||||
|
||||
TUPLE: default { a integer initial: 0 } ;
|
||||
|
||||
CONSTRUCTOR: default ( -- obj ) ;
|
||||
|
||||
[ 0 ] [ <default> a>> ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: slots kernel sequences fry accessors parser lexer words
|
||||
effects.parser macros generalizations locals classes.tuple
|
||||
vocabs generic.standard ;
|
||||
USING: accessors assocs classes.tuple effects.parser fry
|
||||
generalizations generic.standard kernel lexer locals macros
|
||||
parser sequences slots vocabs words ;
|
||||
IN: constructors
|
||||
|
||||
! An experiment
|
||||
|
|
@ -26,14 +26,13 @@ IN: constructors
|
|||
[ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
|
||||
|
||||
MACRO:: slots>constructor ( class slots -- quot )
|
||||
slots class
|
||||
all-slots [ name>> ] map
|
||||
[ '[ _ = ] find drop ] with map
|
||||
[ [ ] count ] [ ] [ length ] tri
|
||||
class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
|
||||
slots length
|
||||
params length
|
||||
'[
|
||||
_ narray _
|
||||
[ swap over [ nth ] [ drop ] if ] with map
|
||||
_ firstn class boa
|
||||
_ narray slots swap zip
|
||||
params swap assoc-union
|
||||
values _ firstn class boa
|
||||
] ;
|
||||
|
||||
:: define-constructor ( constructor-word class effect def -- )
|
||||
|
|
@ -51,3 +50,5 @@ SYNTAX: CONSTRUCTOR:
|
|||
complete-effect
|
||||
parse-definition
|
||||
define-constructor ;
|
||||
|
||||
"initializers" create-vocab drop
|
||||
|
|
|
|||
|
|
@ -15,7 +15,8 @@ IN: images.bitmap
|
|||
: write2 ( n -- ) 2 >le write ;
|
||||
: write4 ( n -- ) 4 >le write ;
|
||||
|
||||
TUPLE: bitmap-image < image ;
|
||||
SINGLETON: bitmap-image
|
||||
"bmp" bitmap-image register-image-class
|
||||
|
||||
TUPLE: loading-bitmap
|
||||
magic size reserved1 reserved2 offset header-length width
|
||||
|
|
@ -212,11 +213,11 @@ ERROR: unknown-bitmap-header n ;
|
|||
|
||||
: parse-bitmap ( loading-bitmap -- loading-bitmap )
|
||||
dup color-palette-length read >>color-palette
|
||||
dup size-image>> [
|
||||
dup size-image>> dup 0 > [
|
||||
read >>color-index
|
||||
] [
|
||||
dup color-index-length read >>color-index
|
||||
] if* ;
|
||||
drop dup color-index-length read >>color-index
|
||||
] if ;
|
||||
|
||||
ERROR: unsupported-bitmap-file magic ;
|
||||
|
||||
|
|
@ -247,7 +248,9 @@ ERROR: unknown-component-order bitmap ;
|
|||
[ unknown-component-order ]
|
||||
} case ;
|
||||
|
||||
: loading-bitmap>image ( image loading-bitmap -- bitmap-image )
|
||||
M: bitmap-image load-image* ( path bitmap-image -- bitmap )
|
||||
drop load-bitmap
|
||||
[ image new ] dip
|
||||
{
|
||||
[ loading-bitmap>bytes >>bitmap ]
|
||||
[ [ width>> ] [ height>> abs ] bi 2array >>dim ]
|
||||
|
|
@ -256,11 +259,6 @@ ERROR: unknown-component-order bitmap ;
|
|||
[ bitmap>component-order >>component-order ]
|
||||
} cleave ;
|
||||
|
||||
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
|
||||
swap load-bitmap loading-bitmap>image ;
|
||||
|
||||
"bmp" bitmap-image register-image-class
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: bitmap>color-index ( bitmap -- byte-array )
|
||||
|
|
|
|||
|
|
@ -34,14 +34,7 @@ TUPLE: image dim component-order upside-down? bitmap ;
|
|||
|
||||
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
|
||||
|
||||
GENERIC: load-image* ( path tuple -- image )
|
||||
|
||||
: make-image ( bitmap -- image )
|
||||
! bitmap is a sequence of sequences of pixels which are RGBA
|
||||
<image>
|
||||
over [ first length ] [ length ] bi 2array >>dim
|
||||
RGBA >>component-order
|
||||
swap concat concat B{ } like >>bitmap ;
|
||||
GENERIC: load-image* ( path class -- image )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
|||
|
|
@ -7,11 +7,13 @@ io.streams.byte-array kernel locals math math.bitwise
|
|||
math.constants math.functions math.matrices math.order
|
||||
math.ranges math.vectors memoize multiline namespaces
|
||||
sequences sequences.deep images.loader ;
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
IN: images.jpeg
|
||||
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
SINGLETON: jpeg-image
|
||||
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
|
||||
|
||||
TUPLE: jpeg-image < image
|
||||
TUPLE: loading-jpeg < image
|
||||
{ headers }
|
||||
{ bitstream }
|
||||
{ color-info initial: { f f f f } }
|
||||
|
|
@ -21,7 +23,7 @@ TUPLE: jpeg-image < image
|
|||
|
||||
<PRIVATE
|
||||
|
||||
CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
|
||||
CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ;
|
||||
|
||||
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
|
||||
APP JPG COM TEM RES ;
|
||||
|
|
@ -63,7 +65,7 @@ TUPLE: jpeg-color-info
|
|||
|
||||
CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
|
||||
|
||||
: jpeg> ( -- jpeg-image ) jpeg-image get ;
|
||||
: jpeg> ( -- jpeg-image ) loading-jpeg get ;
|
||||
|
||||
: apply-diff ( dc color -- dc' )
|
||||
[ diff>> + dup ] [ (>>diff) ] bi ;
|
||||
|
|
@ -291,9 +293,9 @@ PRIVATE>
|
|||
binary [
|
||||
parse-marker { SOI } assert=
|
||||
parse-headers
|
||||
contents <jpeg-image>
|
||||
contents <loading-jpeg>
|
||||
] with-file-reader
|
||||
dup jpeg-image [
|
||||
dup loading-jpeg [
|
||||
baseline-parse
|
||||
baseline-decompress
|
||||
jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
|
||||
|
|
@ -302,5 +304,3 @@ PRIVATE>
|
|||
|
||||
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
|
||||
drop load-jpeg ;
|
||||
|
||||
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
|
||||
|
|
|
|||
|
|
@ -7,16 +7,18 @@ IN: images.loader
|
|||
ERROR: unknown-image-extension extension ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: types
|
||||
types [ H{ } clone ] initialize
|
||||
|
||||
: image-class ( path -- class )
|
||||
file-extension >lower types get ?at
|
||||
[ unknown-image-extension ] unless ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: register-image-class ( extension class -- )
|
||||
swap types get set-at ;
|
||||
|
||||
: load-image ( path -- image )
|
||||
dup image-class new load-image* ;
|
||||
dup image-class load-image* ;
|
||||
|
|
|
|||
|
|
@ -7,12 +7,15 @@ checksums checksums.crc32 compression.inflate grouping byte-arrays
|
|||
images.loader ;
|
||||
IN: images.png
|
||||
|
||||
TUPLE: png-image < image chunks
|
||||
SINGLETON: png-image
|
||||
"png" png-image register-image-class
|
||||
|
||||
TUPLE: loading-png < image chunks
|
||||
width height bit-depth color-type compression-method
|
||||
filter-method interlace-method uncompressed ;
|
||||
|
||||
CONSTRUCTOR: png-image ( -- image )
|
||||
V{ } clone >>chunks ;
|
||||
CONSTRUCTOR: loading-png ( -- image )
|
||||
V{ } clone >>chunks ;
|
||||
|
||||
TUPLE: png-chunk length type data ;
|
||||
|
||||
|
|
@ -105,7 +108,7 @@ ERROR: unimplemented-color-type image ;
|
|||
|
||||
: load-png ( path -- image )
|
||||
binary stream-throws <limited-file-reader> [
|
||||
<png-image>
|
||||
<loading-png>
|
||||
read-png-header
|
||||
read-png-chunks
|
||||
parse-ihdr-chunk
|
||||
|
|
@ -115,5 +118,3 @@ ERROR: unimplemented-color-type image ;
|
|||
|
||||
M: png-image load-image*
|
||||
drop load-png ;
|
||||
|
||||
"png" png-image register-image-class
|
||||
|
|
|
|||
|
|
@ -9,10 +9,10 @@ strings math.vectors specialized-arrays.float locals
|
|||
images.loader ;
|
||||
IN: images.tiff
|
||||
|
||||
TUPLE: tiff-image < image ;
|
||||
SINGLETON: tiff-image
|
||||
|
||||
TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ;
|
||||
CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ;
|
||||
TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
|
||||
CONSTRUCTOR: loading-tiff ( -- tiff ) V{ } clone >>ifds ;
|
||||
|
||||
TUPLE: ifd count ifd-entries next
|
||||
processed-tags strips bitmap ;
|
||||
|
|
@ -410,7 +410,7 @@ ERROR: bad-small-ifd-type n ;
|
|||
[ nip unhandled-ifd-entry swap ]
|
||||
} case ;
|
||||
|
||||
: process-ifds ( parsed-tiff -- parsed-tiff )
|
||||
: process-ifds ( loading-tiff -- loading-tiff )
|
||||
[
|
||||
[
|
||||
dup ifd-entries>>
|
||||
|
|
@ -483,18 +483,6 @@ ERROR: unknown-component-order ifd ;
|
|||
[ unknown-component-order ]
|
||||
} case ;
|
||||
|
||||
: normalize-alpha-data ( seq -- byte-array )
|
||||
B{ } like dup
|
||||
byte-array>float-array
|
||||
4 <sliced-groups>
|
||||
[
|
||||
dup fourth dup 0 = [
|
||||
2drop
|
||||
] [
|
||||
[ 3 head-slice ] dip '[ _ / ] change-each
|
||||
] if
|
||||
] each ;
|
||||
|
||||
: handle-alpha-data ( ifd -- ifd )
|
||||
dup extra-samples find-tag {
|
||||
{ extra-samples-associated-alpha-data [ ] }
|
||||
|
|
@ -508,17 +496,17 @@ ERROR: unknown-component-order ifd ;
|
|||
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
|
||||
[ ifd-component-order f ]
|
||||
[ bitmap>> ]
|
||||
} cleave tiff-image boa ;
|
||||
} cleave image boa ;
|
||||
|
||||
: tiff>image ( image -- image )
|
||||
ifds>> [ ifd>image ] map first ;
|
||||
|
||||
: with-tiff-endianness ( parsed-tiff quot -- )
|
||||
: with-tiff-endianness ( loading-tiff quot -- )
|
||||
[ dup endianness>> ] dip with-endianness ; inline
|
||||
|
||||
: load-tiff-ifds ( path -- parsed-tiff )
|
||||
: load-tiff-ifds ( path -- loading-tiff )
|
||||
binary [
|
||||
<parsed-tiff>
|
||||
<loading-tiff>
|
||||
read-header [
|
||||
dup ifd-offset>> read-ifds
|
||||
process-ifds
|
||||
|
|
@ -550,10 +538,10 @@ ERROR: unknown-component-order ifd ;
|
|||
drop "no planar configuration" throw
|
||||
] if ;
|
||||
|
||||
: process-tif-ifds ( parsed-tiff -- )
|
||||
: process-tif-ifds ( loading-tiff -- )
|
||||
ifds>> [ process-ifd ] each ;
|
||||
|
||||
: load-tiff ( path -- parsed-tiff )
|
||||
: load-tiff ( path -- loading-tiff )
|
||||
[ load-tiff-ifds dup ] keep
|
||||
binary [
|
||||
[ process-tif-ifds ] with-tiff-endianness
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Kobi Lurie, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors fry images.loader images.normalization
|
||||
USING: accessors fry images.loader
|
||||
images.processing.rotation kernel literals math sequences
|
||||
tools.test images.processing.rotation.private ;
|
||||
IN: images.processing.rotation.tests
|
||||
|
|
@ -24,13 +24,13 @@ IN: images.processing.rotation.tests
|
|||
CONSTANT: pasted-image
|
||||
$[
|
||||
"vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"
|
||||
load-image normalize-image clone-image
|
||||
load-image clone-image
|
||||
]
|
||||
|
||||
CONSTANT: pasted-image90
|
||||
$[
|
||||
"vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"
|
||||
load-image normalize-image clone-image
|
||||
load-image clone-image
|
||||
]
|
||||
|
||||
CONSTANT: lake-image
|
||||
|
|
@ -55,7 +55,7 @@ CONSTANT: lake-image
|
|||
"vocab:images/processing/rotation/test-bitmaps/small.bmp"
|
||||
load-image 90 rotate
|
||||
"vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"
|
||||
load-image normalize-image =
|
||||
load-image =
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
|
|
|
|||
Loading…
Reference in New Issue