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

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
+accessors vectors fry heaps cpu.architecture sorting locals
-compiler.cfg.registers
+combinators compiler.cfg.registers
-compiler.cfg.linear-scan.live-intervals ;
+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 -- )
+! Vector of inactive live intervals
-    active-intervals swap '[
+SYMBOL: inactive-intervals
-        [
+
-            [ end>> _ < ] partition
+: inactive-intervals-for ( vreg -- seq )
-            [ [ deallocate-register ] each ] dip
+    reg-class>> inactive-intervals get at ;
-        ] assoc-map
+
-    ] change ;
+: 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 )
+: split-range ( live-range n -- before after )
-    [ uses>> ] 2dip curry find ; inline
+    [ [ from>> ] dip <live-range> ]
+    [ 1 + swap to>> <live-range> ]
+    2bi ;
 
-: split-before ( live-interval i -- before )
+: split-last-range? ( last n -- ? )
-    [ clone dup uses>> ] dip
+    swap to>> <= ;
-    [ head >>uses ] [ 1- swap nth >>end ] 2bi ;
 
-: split-after ( live-interval i -- after )
+: split-last-range ( before after last n -- before' after' )
-    [ clone dup uses>> ] dip
+    split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
-    [ tail >>uses ] [ swap nth >>start ] 2bi
-    f >>reg f >>copy-from ;
 
-: split-interval ( live-interval n -- before after )
+: split-ranges ( live-ranges n -- before after )
-    [ drop ] [ [ > ] find-use drop ] 2bi
+    [ '[ from>> _ <= ] partition ]
-    [ split-before ] [ split-after ] 2bi ;
+    [
+        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
+    swap start>> split-interval assign-spill ;
-    [ record-split ] [ assign-spill ] 2bi ;
 
 : 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 -- )
+: next-intersection ( new inactive -- n )
-    dup coalesce? [
+    2drop 0 ;
-        coalesce
+
+: 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
+        [ split-before-use ] keep
-        [ assign-blocked-register ]
+       '[ _ fits-in-hole ] [ add-unhandled ] bi*
-        [ assign-free-register ]
+    ] 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
+    [ 0 ] reg-class-assoc spill-counts set
-    reg-classes [ V{ } clone ] { } map>assoc active-intervals 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 ]
+        start>>
-    [ assign-register ]
+        [ progress set ]
-    tri ;
+        [ 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
+    init-unhandled
-    (allocate-registers) ;
+    (allocate-registers)
+    finish-allocation
+    handled-intervals get ;

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>> [
+    dup start>> unhandled-intervals get heap-push ;
-        [ split-before>> ] [ split-after>> ] bi
-        [ add-unhandled ] bi@
-    ] [
-        dup start>> unhandled-intervals get heap-push
-    ] if ;
 
 : init-unhandled ( live-intervals -- )
     [ add-unhandled ] each ;

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 } } }
+       { vreg T{ vreg { reg-class int-regs } { n 1 } } }
-        { start 0 }
+       { start 0 }
-        { end 1 }
+       { end 1 }
-        { uses V{ 0 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 } } }
+       { vreg T{ vreg { reg-class int-regs } { n 1 } } }
-        { start 5 }
+       { start 5 }
-        { end 5 }
+       { end 5 }
-        { uses V{ 5 } }
+       { uses V{ 5 } }
+       { ranges V{ T{ live-range f 5 5 } } }
     }
 ] [
     T{ live-interval
-        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+       { vreg T{ vreg { reg-class int-regs } { n 1 } } }
-        { start 0 }
+       { start 0 }
-        { end 5 }
+       { end 5 }
-        { uses V{ 0 1 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
-        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } }
+           { 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
-        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } }
+           { 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
-        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } }
+           { 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
-        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 100 } } }
+           { 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 ] [
+: fake-live-ranges ( seq -- seq' )
-    {
+    [
-        T{ live-interval
+        clone dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
-            { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+    ] map ;
-            { 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
 
 ! 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

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

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

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
+USING: accessors assocs classes.tuple effects.parser fry
-effects.parser macros generalizations locals classes.tuple
+generalizations generic.standard kernel lexer locals macros
-vocabs generic.standard ;
+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
+    class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
-    all-slots [ name>> ] map
+    slots length
-    [ '[ _ = ] find drop ] with map
+    params length
-    [ [ ] count ] [ ] [ length ] tri
     '[
-        _ narray _
+        _ narray slots swap zip 
-        [ swap over [ nth ] [ drop ] if ] with map
+        params swap assoc-union
-        _ firstn class boa
+        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

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
+        drop dup color-index-length read >>color-index
-    ] if* ;
+    ] 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 )

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 )
+GENERIC: load-image* ( path class -- 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 ;
 
 <PRIVATE
 

basis/images/jpeg/jpeg.factor

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

basis/images/loader/loader.factor

@@ -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* ;

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 )
+CONSTRUCTOR: loading-png ( -- image )
-V{ } clone >>chunks ;
+    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

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 ;
+TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
-CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>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

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