diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 908bf2475b..fa10ecfca4 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -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 ] + [ 1 + swap to>> ] + 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 -- ) - 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 + 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 ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 0de350c215..4a9b0b231d 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index e0cbe3774f..cf4daa3ab0 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -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 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 diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 78ac9428d8..546443b289 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -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 -- ) diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor index af1a879ee3..271e173718 100644 --- a/basis/constructors/constructors-tests.factor +++ b/basis/constructors/constructors-tests.factor @@ -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 a>> ] unit-test +[ 1001 ] [ 1000 a>> ] unit-test [ 2 ] [ 0 0 a>> ] unit-test [ 2 ] [ 0 0 0 a>> ] unit-test [ 3 ] [ 0 0 0 0 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 ] unit-test + + +TUPLE: default { a integer initial: 0 } ; + +CONSTRUCTOR: default ( -- obj ) ; + +[ 0 ] [ a>> ] unit-test diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index b08ac0cda3..e6982e3d98 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -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 diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 151c12132b..4f2ad720b6 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -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 ) diff --git a/basis/images/images.factor b/basis/images/images.factor index 62c4f7e2ed..4c76b85459 100755 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -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 - - over [ first length ] [ length ] bi 2array >>dim - RGBA >>component-order - swap concat concat B{ } like >>bitmap ; +GENERIC: load-image* ( path class -- image ) ( -- 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 + contents ] with-file-reader - dup jpeg-image [ + dup loading-jpeg [ baseline-parse baseline-decompress jpeg> bitmap>> 3 [ 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 diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 19f2fd12c8..51d4e0fadf 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -7,16 +7,18 @@ IN: images.loader ERROR: unknown-image-extension 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* ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index b8a9a1d569..fd5e36e212 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -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 [ - + 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 diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index c98f737b11..876076e9fe 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -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 - [ - 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 [ - + 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 diff --git a/extra/images/processing/rotation/rotation-tests.factor b/extra/images/processing/rotation/rotation-tests.factor index 493f09b145..9d9e72a205 100755 --- a/extra/images/processing/rotation/rotation-tests.factor +++ b/extra/images/processing/rotation/rotation-tests.factor @@ -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 ] [