Merge commit 'origin/master' into emacs

basis/bitstreams/bitstreams.factor

@@ -158,3 +158,9 @@ M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
         writer bytes>> swap push
     ] unless
     writer bytes>> ;
+
+:: byte-array-n>seq ( byte-array n -- seq )
+    byte-array length 8 * n / iota
+    byte-array <msb0-bit-reader> '[
+        drop n _ read
+    ] { } map-as ;

basis/compiler/cfg/build-stack-frame/build-stack-frame.factor

@@ -0,0 +1,74 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces accessors math.order assocs kernel sequences
+combinators make classes words cpu.architecture
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.stack-frame ;
+IN: compiler.cfg.build-stack-frame
+
+SYMBOL: frame-required?
+
+SYMBOL: spill-counts
+
+GENERIC: compute-stack-frame* ( insn -- )
+
+: request-stack-frame ( stack-frame -- )
+    stack-frame [ max-stack-frame ] change ;
+
+M: ##stack-frame compute-stack-frame*
+    frame-required? on
+    stack-frame>> request-stack-frame ;
+
+M: ##call compute-stack-frame*
+    word>> sub-primitive>> [ frame-required? on ] unless ;
+
+M: _gc compute-stack-frame*
+    frame-required? on
+    stack-frame new swap gc-root-size>> >>gc-root-size
+    request-stack-frame ;
+
+M: _spill-counts compute-stack-frame*
+    counts>> stack-frame get (>>spill-counts) ;
+
+M: insn compute-stack-frame*
+    class frame-required? word-prop [
+        frame-required? on
+    ] when ;
+
+\ _spill t frame-required? set-word-prop
+\ ##fixnum-add t frame-required? set-word-prop
+\ ##fixnum-sub t frame-required? set-word-prop
+\ ##fixnum-mul t frame-required? set-word-prop
+\ ##fixnum-add-tail f frame-required? set-word-prop
+\ ##fixnum-sub-tail f frame-required? set-word-prop
+\ ##fixnum-mul-tail f frame-required? set-word-prop
+
+: compute-stack-frame ( insns -- )
+    frame-required? off
+    T{ stack-frame } clone stack-frame set
+    [ compute-stack-frame* ] each
+    stack-frame get dup stack-frame-size >>total-size drop ;
+
+GENERIC: insert-pro/epilogues* ( insn -- )
+
+M: ##stack-frame insert-pro/epilogues* drop ;
+
+M: ##prologue insert-pro/epilogues*
+    drop frame-required? get [ stack-frame get _prologue ] when ;
+
+M: ##epilogue insert-pro/epilogues*
+    drop frame-required? get [ stack-frame get _epilogue ] when ;
+
+M: insn insert-pro/epilogues* , ;
+
+: insert-pro/epilogues ( insns -- insns )
+    [ [ insert-pro/epilogues* ] each ] { } make ;
+
+: build-stack-frame ( mr -- mr )
+    [
+        [
+            [ compute-stack-frame ]
+            [ insert-pro/epilogues ]
+            bi
+        ] change-instructions
+    ] with-scope ;

basis/compiler/cfg/builder/builder.factor

@@ -15,6 +15,7 @@ compiler.cfg.iterator
 compiler.cfg.utilities
 compiler.cfg.registers
 compiler.cfg.intrinsics
+compiler.cfg.stack-frame
 compiler.cfg.instructions
 compiler.alien ;
 IN: compiler.cfg.builder

basis/compiler/cfg/def-use/def-use.factor

@@ -8,14 +8,6 @@ GENERIC: temp-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
 
 M: ##flushable defs-vregs dst>> 1array ;
-M: ##unary/temp defs-vregs dst>> 1array ;
-M: ##allot defs-vregs dst>> 1array ;
-M: ##slot defs-vregs dst>> 1array ;
-M: ##set-slot defs-vregs temp>> 1array ;
-M: ##string-nth defs-vregs dst>> 1array ;
-M: ##compare defs-vregs dst>> 1array ;
-M: ##compare-imm defs-vregs dst>> 1array ;
-M: ##compare-float defs-vregs dst>> 1array ;
 M: insn defs-vregs drop f ;
 
 M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
@@ -31,6 +23,7 @@ M: ##compare-imm temp-vregs temp>> 1array ;
 M: ##compare-float temp-vregs temp>> 1array ;
 M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
 M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
 M: _dispatch temp-vregs temp>> 1array ;
 M: insn temp-vregs drop f ;
 
@@ -51,7 +44,6 @@ M: ##alien-getter uses-vregs src>> 1array ;
 M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
 M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: ##phi uses-vregs inputs>> ;
-M: ##gc uses-vregs live-in>> ;
 M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: _compare-imm-branch uses-vregs src1>> 1array ;
 M: _dispatch uses-vregs src>> 1array ;

basis/compiler/cfg/gc-checks/gc-checks.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences assocs
 cpu.architecture compiler.cfg.rpo
-compiler.cfg.liveness compiler.cfg.instructions ;
+compiler.cfg.liveness compiler.cfg.instructions
+compiler.cfg.hats ;
 IN: compiler.cfg.gc-checks
 
 : gc? ( bb -- ? )
@@ -13,9 +14,7 @@ IN: compiler.cfg.gc-checks
 
 : insert-gc-check ( basic-block -- )
     dup gc? [
-        dup
+        [ i i f f \ ##gc new-insn prefix ] change-instructions drop
-        [ swap object-pointer-regs \ ##gc new-insn prefix ]
-        change-instructions drop
     ] [ drop ] if ;
 
 : insert-gc-checks ( cfg -- cfg' )

basis/compiler/cfg/instructions/instructions.factor

@@ -52,12 +52,6 @@ INSN: ##inc-d { n integer } ;
 INSN: ##inc-r { n integer } ;
 
 ! Subroutine calls
-TUPLE: stack-frame
-{ params integer }
-{ return integer }
-{ total-size integer }
-spill-counts ;
-
 INSN: ##stack-frame stack-frame ;
 INSN: ##call word { height integer } ;
 INSN: ##jump word ;
@@ -223,7 +217,7 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
 INSN: ##compare-float-branch < ##conditional-branch ;
 INSN: ##compare-float < ##binary cc temp ;
 
-INSN: ##gc live-in ;
+INSN: ##gc { temp1 vreg } { temp2 vreg } live-registers live-spill-slots ;
 
 ! Instructions used by machine IR only.
 INSN: _prologue stack-frame ;
@@ -243,6 +237,10 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
 
 INSN: _compare-float-branch < _conditional-branch ;
 
+TUPLE: spill-slot n ; C: <spill-slot> spill-slot
+
+INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
+
 ! These instructions operate on machine registers and not
 ! virtual registers
 INSN: _spill src class n ;

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 ;
@@ -58,17 +53,34 @@ SYMBOL: unhandled-intervals
         ] [ 2drop ] if
     ] if ;
 
-GENERIC: assign-registers-in-insn ( insn -- )
+GENERIC: assign-before ( insn -- )
+
+GENERIC: assign-after ( insn -- )
 
 : all-vregs ( insn -- vregs )
     [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
 
-M: vreg-insn assign-registers-in-insn
+M: vreg-insn assign-before
     active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter
     [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
     >>regs drop ;
 
-M: insn assign-registers-in-insn drop ;
+M: insn assign-before drop ;
+
+: compute-live-registers ( -- regs )
+    active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
+
+: compute-live-spill-slots ( -- spill-slots )
+    unhandled-intervals get
+    heap-values [ reload-from>> ] filter
+    [ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
+
+M: ##gc assign-after
+    compute-live-registers >>live-registers
+    compute-live-spill-slots >>live-spill-slots
+    drop ;
+
+M: insn assign-after drop ;
 
 : <active-intervals> ( -- obj )
     V{ } clone active-intervals boa ;
@@ -82,10 +94,13 @@ M: insn assign-registers-in-insn drop ;
     [
         [
             [
-                [ insn#>> activate-new-intervals ]
+                {
-                [ [ assign-registers-in-insn ] [ , ] bi ]
+                    [ insn#>> activate-new-intervals ]
-                [ insn#>> expire-old-intervals ]
+                    [ assign-before ]
-                tri
+                    [ , ]
+                    [ insn#>> expire-old-intervals ]
+                    [ assign-after ]
+                } cleave
             ] each
         ] V{ } make
     ] change-instructions drop ;

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
@@ -242,11 +356,12 @@ SYMBOL: max-uses
         max-insns get [ 0 ] replicate taken set
         max-insns get [ dup ] H{ } map>assoc available set
         [
-            live-interval new
+            \ live-interval new
                 swap int-regs swap vreg boa >>vreg
                 max-uses get random 2 max [ not-taken ] replicate natural-sort
                 [ >>uses ] [ first >>start ] bi
                 dup uses>> last >>end
+                dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
         ] map
     ] with-scope ;
 
@@ -271,49 +386,10 @@ USING: math.private compiler.cfg.debugger ;
     test-cfg first optimize-cfg linear-scan drop
 ] unit-test
 
-[ f ] [
+: fake-live-ranges ( seq -- seq' )
-    T{ basic-block
+    [
-       { instructions
+        clone dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
-         V{
+    ] map ;
-             T{ ##allot
-                f
-                T{ vreg f int-regs 1 }
-                40
-                array
-                T{ vreg f int-regs 2 }
-                f
-             }
-         }
-       }
-    } clone [ [ clone ] map ] change-instructions
-    dup 1array (linear-scan) instructions>> first regs>> values all-equal?
-] 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
 
 ! Coalescing interacted badly with splitting
 [ ] [
@@ -362,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
@@ -1117,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
@@ -1210,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,26 +1,56 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs accessors sequences math fry
+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.def-use compiler.cfg.liveness compiler.cfg ;
 IN: compiler.cfg.linear-scan.live-intervals
 
+TUPLE: live-range from to ;
+
+C: <live-range> live-range
+
 TUPLE: live-interval
 vreg
 reg spill-to reload-from split-before split-after
-start end uses
+start end ranges uses
 copy-from ;
 
-: add-use ( n live-interval -- )
+ERROR: dead-value-error vreg ;
-    dup live-interval? [ "No def" throw ] unless
-    [ (>>end) ] [ uses>> push ] 2bi ;
 
-: <live-interval> ( start vreg -- live-interval )
+: shorten-range ( n live-interval -- )
-    live-interval new
+    dup ranges>> empty?
+    [ vreg>> dead-value-error ] [ ranges>> last (>>from) ] if ;
+
+: extend-range ( from to live-range -- )
+    ranges>> last
+    [ max ] change-to
+    [ min ] change-from
+    drop ;
+
+: add-new-range ( from to live-interval -- )
+    [ <live-range> ] dip ranges>> push ;
+
+: extend-range? ( to live-interval -- ? )
+    ranges>> [ drop f ] [ last from>> >= ] if-empty ;
+
+: add-range ( from to live-interval -- )
+    2dup extend-range?
+    [ extend-range ] [ add-new-range ] if ;
+
+: add-use ( n live-interval -- )
+    uses>> push ;
+
+: <live-interval> ( vreg -- live-interval )
+    \ live-interval new
         V{ } clone >>uses
-        swap >>vreg
+        V{ } clone >>ranges
-        over >>start
+        swap >>vreg ;
-        [ add-use ] keep ;
+
+: block-from ( -- n )
+    basic-block get instructions>> first insn#>> ;
+
+: block-to ( -- n )
+    basic-block get instructions>> last insn#>> ;
 
 M: live-interval hashcode*
     nip [ start>> ] [ end>> 1000 * ] bi + ;
@@ -31,23 +61,31 @@ M: live-interval clone
 ! Mapping from vreg to live-interval
 SYMBOL: live-intervals
 
-: new-live-interval ( n vreg live-intervals -- )
+: live-interval ( vreg live-intervals -- live-interval )
-    2dup key? [
+    [ <live-interval> ] cache ;
-        at add-use
-    ] [
-        [ [ <live-interval> ] keep ] dip set-at
-    ] if ;
 
 GENERIC: compute-live-intervals* ( insn -- )
 
 M: insn compute-live-intervals* drop ;
 
+: handle-output ( n vreg live-intervals -- )
+    live-interval
+    [ add-use ] [ shorten-range ] 2bi ;
+
+: handle-input ( n vreg live-intervals -- )
+    live-interval
+    [ [ block-from ] 2dip add-range ] [ add-use ] 2bi ;
+
+: handle-temp ( n vreg live-intervals -- )
+    live-interval
+    [ dupd add-range ] [ add-use ] 2bi ;
+
 M: vreg-insn compute-live-intervals*
     dup insn#>>
     live-intervals get
-    [ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
+    [ [ defs-vregs ] 2dip '[ [ _ ] dip _ handle-output ] each ]
-    [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
+    [ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ]
-    [ [ temp-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
+    [ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
     3tri ;
 
 : record-copy ( insn -- )
@@ -59,8 +97,33 @@ M: ##copy compute-live-intervals*
 M: ##copy-float compute-live-intervals*
     [ call-next-method ] [ record-copy ] bi ;
 
+: handle-live-out ( bb -- )
+    live-out keys block-from block-to live-intervals get '[
+        [ _ _ ] dip _ live-interval add-range
+    ] each ;
+
+: compute-live-intervals-step ( bb -- )
+    [ basic-block set ]
+    [ handle-live-out ]
+    [ instructions>> <reversed> [ compute-live-intervals* ] each ] tri ;
+
+: 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 -- )
+    ! Since live intervals are computed in a backward order, we have
+    ! to reverse some sequences, and compute the start and end.
+    [
+        [ ranges>> reverse-here ]
+        [ uses>> reverse-here ]
+        [ compute-start/end ]
+        tri
+    ] each ;
+
 : compute-live-intervals ( rpo -- live-intervals )
     H{ } clone [
         live-intervals set
-        [ instructions>> [ compute-live-intervals* ] each ] each
+        <reversed> [ compute-live-intervals-step ] each
-    ] keep values ;
+    ] keep values dup finish-live-intervals ;

basis/compiler/cfg/linearization/linearization.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math accessors sequences namespaces make
-combinators assocs
+combinators assocs arrays locals cpu.architecture
-cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.liveness
+compiler.cfg.stack-frame
 compiler.cfg.instructions ;
 IN: compiler.cfg.linearization
 
@@ -68,6 +68,57 @@ M: ##dispatch linearize-insn
     [ successors>> [ number>> _dispatch-label ] each ]
     bi* ;
 
+: gc-root-registers ( n live-registers -- n )
+    [
+        [ second 2array , ]
+        [ first reg-class>> reg-size + ]
+        2bi
+    ] each ;
+
+: gc-root-spill-slots ( n live-spill-slots -- n )
+    [
+        dup first reg-class>> int-regs eq? [
+            [ second <spill-slot> 2array , ]
+            [ first reg-class>> reg-size + ]
+            2bi
+        ] [ drop ] if
+    ] each ;
+
+: oop-registers ( regs -- regs' )
+    [ first reg-class>> int-regs eq? ] filter ;
+
+: data-registers ( regs -- regs' )
+    [ first reg-class>> double-float-regs eq? ] filter ;
+
+:: compute-gc-roots ( live-registers live-spill-slots -- alist )
+    [
+        0
+        ! we put float registers last; the GC doesn't actually scan them
+        live-registers oop-registers gc-root-registers
+        live-spill-slots gc-root-spill-slots
+        live-registers data-registers gc-root-registers
+        drop
+    ] { } make ;
+
+: count-gc-roots ( live-registers live-spill-slots -- n )
+    ! Size of GC root area, minus the float registers
+    [ oop-registers length ] bi@ + ;
+
+M: ##gc linearize-insn
+    nip
+    [
+        [ temp1>> ]
+        [ temp2>> ]
+        [
+            [ live-registers>> ] [ live-spill-slots>> ] bi
+            [ compute-gc-roots ]
+            [ count-gc-roots ]
+            [ gc-roots-size ]
+            2tri
+        ] tri
+        _gc
+    ] with-regs ;
+
 : linearize-basic-blocks ( cfg -- insns )
     [
         [ [ linearize-basic-block ] each-basic-block ]

basis/compiler/cfg/mr/mr.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: compiler.cfg.linearization compiler.cfg.two-operand
 compiler.cfg.liveness compiler.cfg.gc-checks compiler.cfg.linear-scan
-compiler.cfg.stack-frame compiler.cfg.rpo ;
+compiler.cfg.build-stack-frame compiler.cfg.rpo ;
 IN: compiler.cfg.mr
 
 : build-mr ( cfg -- mr )

basis/compiler/cfg/stack-frame/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/compiler/cfg/stack-frame/stack-frame.factor

@@ -1,72 +1,55 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces accessors math.order assocs kernel sequences
+USING: math math.order namespaces accessors kernel layouts combinators
-combinators make classes words cpu.architecture
+combinators.smart assocs sequences cpu.architecture ;
-compiler.cfg.instructions compiler.cfg.registers ;
 IN: compiler.cfg.stack-frame
 
-SYMBOL: frame-required?
+TUPLE: stack-frame
+{ params integer }
+{ return integer }
+{ total-size integer }
+{ gc-root-size integer }
+spill-counts ;
 
-SYMBOL: spill-counts
+! Stack frame utilities
+: param-base ( -- n )
+    stack-frame get [ params>> ] [ return>> ] bi + ;
 
-GENERIC: compute-stack-frame* ( insn -- )
+: spill-float-offset ( n -- offset )
+    double-float-regs reg-size * ;
+
+: spill-integer-base ( -- n )
+    stack-frame get spill-counts>> double-float-regs [ swap at ] keep reg-size *
+    param-base + ;
+
+: spill-integer-offset ( n -- offset )
+    cells spill-integer-base + ;
+
+: spill-area-size ( stack-frame -- n )
+    spill-counts>> [ swap reg-size * ] { } assoc>map sum ;
+
+: gc-root-base ( -- n )
+    stack-frame get spill-area-size
+    param-base + ;
+
+: gc-root-offset ( n -- n' ) gc-root-base + ;
+
+: gc-roots-size ( live-registers live-spill-slots -- n )
+    [ keys [ reg-class>> reg-size ] sigma ] bi@ + ;
+
+: (stack-frame-size) ( stack-frame -- n )
+    [
+        {
+            [ spill-area-size ]
+            [ gc-root-size>> ]
+            [ params>> ]
+            [ return>> ]
+        } cleave
+    ] sum-outputs ;
 
 : max-stack-frame ( frame1 frame2 -- frame3 )
     [ stack-frame new ] 2dip
         [ [ params>> ] bi@ max >>params ]
         [ [ return>> ] bi@ max >>return ]
-        2bi ;
+        [ [ gc-root-size>> ] bi@ max >>gc-root-size ]
-
+        2tri ;
-M: ##stack-frame compute-stack-frame*
-    frame-required? on
-    stack-frame>> stack-frame [ max-stack-frame ] change ;
-
-M: ##call compute-stack-frame*
-    word>> sub-primitive>> [ frame-required? on ] unless ;
-
-M: _spill-counts compute-stack-frame*
-    counts>> stack-frame get (>>spill-counts) ;
-
-M: insn compute-stack-frame*
-    class frame-required? word-prop [
-        frame-required? on
-    ] when ;
-
-\ _spill t frame-required? set-word-prop
-\ ##gc t frame-required? set-word-prop
-\ ##fixnum-add t frame-required? set-word-prop
-\ ##fixnum-sub t frame-required? set-word-prop
-\ ##fixnum-mul t frame-required? set-word-prop
-\ ##fixnum-add-tail f frame-required? set-word-prop
-\ ##fixnum-sub-tail f frame-required? set-word-prop
-\ ##fixnum-mul-tail f frame-required? set-word-prop
-
-: compute-stack-frame ( insns -- )
-    frame-required? off
-    T{ stack-frame } clone stack-frame set
-    [ compute-stack-frame* ] each
-    stack-frame get dup stack-frame-size >>total-size drop ;
-
-GENERIC: insert-pro/epilogues* ( insn -- )
-
-M: ##stack-frame insert-pro/epilogues* drop ;
-
-M: ##prologue insert-pro/epilogues*
-    drop frame-required? get [ stack-frame get _prologue ] when ;
-
-M: ##epilogue insert-pro/epilogues*
-    drop frame-required? get [ stack-frame get _epilogue ] when ;
-
-M: insn insert-pro/epilogues* , ;
-
-: insert-pro/epilogues ( insns -- insns )
-    [ [ insert-pro/epilogues* ] each ] { } make ;
-
-: build-stack-frame ( mr -- mr )
-    [
-        [
-            [ compute-stack-frame ]
-            [ insert-pro/epilogues ]
-            bi
-        ] change-instructions
-    ] with-scope ;

basis/compiler/codegen/codegen.factor

@@ -10,6 +10,7 @@ compiler.errors
 compiler.alien
 compiler.cfg
 compiler.cfg.instructions
+compiler.cfg.stack-frame
 compiler.cfg.registers
 compiler.cfg.builder
 compiler.codegen.fixup
@@ -234,7 +235,13 @@ M: ##write-barrier generate-insn
     [ table>> register ]
     tri %write-barrier ;
 
-M: ##gc generate-insn drop %gc ;
+M: _gc generate-insn
+    {
+        [ temp1>> register ]
+        [ temp2>> register ]
+        [ gc-roots>> ]
+        [ gc-root-count>> ]
+    } cleave %gc ;
 
 M: ##loop-entry generate-insn drop %loop-entry ;
 
@@ -243,16 +250,6 @@ M: ##alien-global generate-insn
     %alien-global ;
 
 ! ##alien-invoke
-GENERIC: reg-size ( register-class -- n )
-
-M: int-regs reg-size drop cell ;
-
-M: single-float-regs reg-size drop 4 ;
-
-M: double-float-regs reg-size drop 8 ;
-
-M: stack-params reg-size drop "void*" heap-size ;
-
 GENERIC: reg-class-variable ( register-class -- symbol )
 
 M: reg-class reg-class-variable ;

basis/compiler/tests/codegen.factor

@@ -2,7 +2,7 @@ USING: generalizations accessors arrays compiler kernel kernel.private
 math hashtables.private math.private namespaces sequences tools.test
 namespaces.private slots.private sequences.private byte-arrays alien
 alien.accessors layouts words definitions compiler.units io
-combinators vectors grouping make ;
+combinators vectors grouping make alien.c-types ;
 QUALIFIED: namespaces.private
 IN: compiler.tests.codegen
 
@@ -282,3 +282,10 @@ TUPLE: cucumber ;
 M: cucumber equal? "The cucumber has no equal" throw ;
 
 [ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
+
+[ 4294967295 B{ 255 255 255 255 } -1 ]
+[
+    -1 <int> -1 <int>
+    [ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ]
+    compile-call
+] unit-test

basis/compression/run-length/run-length.factor

@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays grouping sequences ;
+IN: compression.run-length
+
+: run-length-uncompress ( byte-array -- byte-array' )
+    2 group [ first2 <array> ] map concat ;

basis/constructors/constructors-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.test constructors calendar kernel accessors
-combinators.short-circuit ;
+combinators.short-circuit initializers math ;
 IN: constructors.tests
 
 TUPLE: stock-spread stock spread timestamp ;
@@ -19,3 +19,41 @@ SYMBOL: AAPL
         [ timestamp>> timestamp? ]
     } 1&&
 ] unit-test
+
+TUPLE: ct1 a ;
+TUPLE: ct2 < ct1 b ;
+TUPLE: ct3 < ct2 c ;
+TUPLE: ct4 < ct3 d ;
+
+CONSTRUCTOR: ct1 ( a -- obj )
+    [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct2 ( a b -- obj )
+    initialize-ct1
+    [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct3 ( a b c -- obj )
+    initialize-ct1
+    [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct4 ( a b c d -- obj )
+    initialize-ct3
+    [ 1 + ] change-a ;
+
+[ 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,23 +1,54 @@
-! Copyright (C) 2009 Slava Pestov.
+! 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 generic.standard kernel lexer locals macros
+parser sequences slots vocabs words ;
 IN: constructors
 
 ! An experiment
 
-MACRO: set-slots ( slots -- quot )
+: initializer-name ( class -- word )
-    <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
+    name>> "initialize-" prepend ;
 
-: construct ( ... class slots -- instance )
+: lookup-initializer ( class -- word/f )
-    [ new ] dip set-slots ; inline
+    initializer-name "initializers" lookup ;
 
-: define-constructor ( name class effect body -- )
+: initializer-word ( class -- word )
-    [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
+    initializer-name
-    define-declared ;
+    "initializers" create-vocab create
+    [ t "initializer" set-word-prop ] [ ] bi ;
+
+: define-initializer-generic ( name -- )
+    initializer-word (( object -- object )) define-simple-generic ;
+
+: define-initializer ( class def -- )
+    [ drop define-initializer-generic ]
+    [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
+
+MACRO:: slots>constructor ( class slots -- quot )
+    class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
+    slots length
+    params length
+    '[
+        _ narray slots swap zip 
+        params swap assoc-union
+        values _ firstn class boa
+    ] ;
+
+:: define-constructor ( constructor-word class effect def -- )
+    constructor-word
+    class def define-initializer
+    class effect in>> '[ _ _ slots>constructor ]
+    class lookup-initializer
+    '[ @ _ execute( obj -- obj ) ] effect define-declared ;
+
+: scan-constructor ( -- class word )
+    scan-word [ name>> "<" ">" surround create-in ] keep ;
 
 SYNTAX: CONSTRUCTOR:
-    scan-word [ name>> "<" ">" surround create-in ] keep
+    scan-constructor
     complete-effect
     parse-definition
     define-constructor ;
+
+"initializers" create-vocab drop

basis/cpu/architecture/architecture.factor

@@ -12,12 +12,22 @@ SINGLETON: double-float-regs
 UNION: float-regs single-float-regs double-float-regs ;
 UNION: reg-class int-regs float-regs ;
 
-! Mapping from register class to machine registers
-HOOK: machine-registers cpu ( -- assoc )
-
 ! A pseudo-register class for parameters spilled on the stack
 SINGLETON: stack-params
 
+GENERIC: reg-size ( register-class -- n )
+
+M: int-regs reg-size drop cell ;
+
+M: single-float-regs reg-size drop 4 ;
+
+M: double-float-regs reg-size drop 8 ;
+
+M: stack-params reg-size drop cell ;
+
+! Mapping from register class to machine registers
+HOOK: machine-registers cpu ( -- assoc )
+
 ! Return values of this class go here
 GENERIC: return-reg ( register-class -- reg )
 
@@ -119,7 +129,7 @@ HOOK: %alien-global cpu ( dst symbol library -- )
 
 HOOK: %allot cpu ( dst size class temp -- )
 HOOK: %write-barrier cpu ( src card# table -- )
-HOOK: %gc cpu ( -- )
+HOOK: %gc cpu ( temp1 temp2 live-registers live-spill-slots -- )
 
 HOOK: %prologue cpu ( n -- )
 HOOK: %epilogue cpu ( n -- )

basis/cpu/x86/32/32.factor

@@ -3,10 +3,11 @@
 USING: locals alien.c-types alien.syntax arrays kernel
 math namespaces sequences system layouts io vocabs.loader
 accessors init combinators command-line cpu.x86.assembler
-cpu.x86 cpu.architecture compiler compiler.units
+cpu.x86 cpu.architecture make compiler compiler.units
 compiler.constants compiler.alien compiler.codegen
 compiler.codegen.fixup compiler.cfg.instructions
-compiler.cfg.builder compiler.cfg.intrinsics make ;
+compiler.cfg.builder compiler.cfg.intrinsics
+compiler.cfg.stack-frame ;
 IN: cpu.x86.32
 
 ! We implement the FFI for Linux, OS X and Windows all at once.

basis/cpu/x86/64/64.factor

@@ -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 arrays kernel math namespaces make sequences
 system layouts alien alien.c-types alien.accessors alien.structs
@@ -6,7 +6,7 @@ slots splitting assocs combinators locals cpu.x86.assembler
 cpu.x86 cpu.architecture compiler.constants
 compiler.codegen compiler.codegen.fixup
 compiler.cfg.instructions compiler.cfg.builder
-compiler.cfg.intrinsics ;
+compiler.cfg.intrinsics compiler.cfg.stack-frame ;
 IN: cpu.x86.64
 
 M: x86.64 machine-registers

basis/cpu/x86/x86.factor

@@ -6,7 +6,7 @@ kernel kernel.private math memory namespaces make sequences
 words system layouts combinators math.order fry locals
 compiler.constants compiler.cfg.registers
 compiler.cfg.instructions compiler.cfg.intrinsics
-compiler.codegen compiler.codegen.fixup ;
+compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup ;
 IN: cpu.x86
 
 << enable-fixnum-log2 >>
@@ -17,6 +17,32 @@ M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
 
 M: x86 two-operand? t ;
 
+HOOK: stack-reg cpu ( -- reg )
+
+HOOK: reserved-area-size cpu ( -- n )
+
+: stack@ ( n -- op ) stack-reg swap [+] ;
+
+: param@ ( n -- op ) reserved-area-size + stack@ ;
+
+: spill-integer@ ( n -- op ) spill-integer-offset param@ ;
+
+: spill-float@ ( n -- op ) spill-float-offset param@ ;
+
+: gc-root@ ( n -- op ) gc-root-offset param@ ;
+
+: decr-stack-reg ( n -- )
+    dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
+
+: incr-stack-reg ( n -- )
+    dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
+
+: align-stack ( n -- n' )
+    os macosx? cpu x86.64? or [ 16 align ] when ;
+
+M: x86 stack-frame-size ( stack-frame -- i )
+    (stack-frame-size) 3 cells reserved-area-size + + align-stack ;
+
 HOOK: temp-reg-1 cpu ( -- reg )
 HOOK: temp-reg-2 cpu ( -- reg )
 
@@ -45,20 +71,6 @@ M: x86 %replace loc>operand swap MOV ;
 M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
 M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
 
-: align-stack ( n -- n' )
-    os macosx? cpu x86.64? or [ 16 align ] when ;
-
-HOOK: reserved-area-size cpu ( -- n )
-
-M: x86 stack-frame-size ( stack-frame -- i )
-    [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
-    [ params>> ]
-    [ return>> ]
-    tri + +
-    3 cells +
-    reserved-area-size +
-    align-stack ;
-
 M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
 
 : xt-tail-pic-offset ( -- n )
@@ -315,17 +327,29 @@ M:: x86 %box-alien ( dst src temp -- )
         "end" resolve-label
     ] with-scope ;
 
-: small-reg-4 ( reg -- reg' )
+: small-reg-8 ( reg -- reg' )
     H{
-        { EAX EAX }
+        { EAX RAX }
-        { ECX ECX }
+        { ECX RCX }
-        { EDX EDX }
+        { EDX RDX }
-        { EBX EBX }
+        { EBX RBX }
-        { ESP ESP }
+        { ESP RSP }
-        { EBP EBP }
+        { EBP RBP }
-        { ESI ESP }
+        { ESI RSP }
-        { EDI EDI }
+        { EDI RDI }
 
+        { RAX RAX }
+        { RCX RCX }
+        { RDX RDX }
+        { RBX RBX }
+        { RSP RSP }
+        { RBP RBP }
+        { RSI RSP }
+        { RDI RDI }
+    } at ; inline
+
+: small-reg-4 ( reg -- reg' )
+    small-reg-8 H{
         { RAX EAX }
         { RCX ECX }
         { RDX EDX }
@@ -361,12 +385,21 @@ M:: x86 %box-alien ( dst src temp -- )
         { 1 [ small-reg-1 ] }
         { 2 [ small-reg-2 ] }
         { 4 [ small-reg-4 ] }
+        { 8 [ small-reg-8 ] }
     } case ;
 
-: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
+HOOK: small-regs cpu ( -- regs )
+
+M: x86.32 small-regs { EAX ECX EDX EBX } ;
+M: x86.64 small-regs { RAX RCX RDX RBX } ;
+
+HOOK: small-reg-native cpu ( reg -- reg' )
+
+M: x86.32 small-reg-native small-reg-4 ;
+M: x86.64 small-reg-native small-reg-8 ;
 
 : small-reg-that-isn't ( exclude -- reg' )
-    small-regs swap [ small-reg-4 ] map '[ _ memq? not ] find nip ;
+    small-regs swap [ small-reg-native ] map '[ _ memq? not ] find nip ;
 
 : with-save/restore ( reg quot -- )
     [ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
@@ -376,7 +409,7 @@ M:: x86 %box-alien ( dst src temp -- )
     #! call the quot with that. Otherwise, we find a small
     #! register that is not in exclude, and call quot, saving
     #! and restoring the small register.
-    dst small-reg-4 small-regs memq? [ dst quot call ] [
+    dst small-reg-native small-regs memq? [ dst quot call ] [
         exclude small-reg-that-isn't
         [ quot call ] with-save/restore
     ] if ; inline
@@ -492,29 +525,58 @@ M:: x86 %write-barrier ( src card# table -- )
     table table [] MOV
     table card# [+] card-mark <byte> MOV ;
 
-M: x86 %gc ( -- )
+:: check-nursery ( temp1 temp2 -- )
-    "end" define-label
+    temp1 load-zone-ptr
-    temp-reg-1 load-zone-ptr
+    temp2 temp1 cell [+] MOV
-    temp-reg-2 temp-reg-1 cell [+] MOV
+    temp2 1024 ADD
-    temp-reg-2 1024 ADD
+    temp1 temp1 3 cells [+] MOV
-    temp-reg-1 temp-reg-1 3 cells [+] MOV
+    temp2 temp1 CMP ;
-    temp-reg-2 temp-reg-1 CMP
+
-    "end" get JLE
+GENERIC# save-gc-root 1 ( gc-root operand temp -- )
+
+M:: spill-slot save-gc-root ( gc-root spill-slot temp -- )
+    temp spill-slot n>> spill-integer@ MOV
+    gc-root gc-root@ temp MOV ;
+
+M:: word save-gc-root ( gc-root register temp -- )
+    gc-root gc-root@ register MOV ;
+
+: save-gc-roots ( gc-roots temp -- )
+    '[ _ save-gc-root ] assoc-each ;
+
+GENERIC# load-gc-root 1 ( gc-root operand temp -- )
+
+M:: spill-slot load-gc-root ( gc-root spill-slot temp -- )
+    temp gc-root gc-root@ MOV
+    spill-slot n>> spill-integer@ temp MOV ;
+
+M:: word load-gc-root ( gc-root register temp -- )
+    register gc-root gc-root@ MOV ;
+
+: load-gc-roots ( gc-roots temp -- )
+    '[ _ load-gc-root ] assoc-each ;
+
+:: call-gc ( gc-root-count -- )
+    ! Pass pointer to start of GC roots as first parameter
+    param-reg-1 gc-root-base param@ LEA
+    ! Pass number of roots as second parameter
+    param-reg-2 gc-root-count MOV
+    ! Call GC
     %prepare-alien-invoke
-    "minor_gc" f %alien-invoke
+    "inline_gc" f %alien-invoke ;
+
+M:: x86 %gc ( temp1 temp2 gc-roots gc-root-count -- )
+    "end" define-label
+    temp1 temp2 check-nursery
+    "end" get JLE
+    gc-roots temp1 save-gc-roots
+    gc-root-count call-gc
+    gc-roots temp1 load-gc-roots
     "end" resolve-label ;
 
 M: x86 %alien-global
     [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
 
-HOOK: stack-reg cpu ( -- reg )
-
-: decr-stack-reg ( n -- )
-    dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
-
-: incr-stack-reg ( n -- )
-    dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
-
 M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
 
 :: %boolean ( dst temp word -- )
@@ -568,28 +630,6 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
         { cc/= [ JNE ] }
     } case ;
 
-: stack@ ( n -- op ) stack-reg swap [+] ;
-
-: param@ ( n -- op ) reserved-area-size + stack@ ;
-
-: spill-integer-base ( stack-frame -- n )
-    [ params>> ] [ return>> ] bi + reserved-area-size + ;
-
-: spill-integer@ ( n -- op )
-    cells
-    stack-frame get spill-integer-base
-    + stack@ ;
-
-: spill-float-base ( stack-frame -- n )
-    [ spill-integer-base ]
-    [ spill-counts>> int-regs swap at int-regs reg-size * ]
-    bi + ;
-
-: spill-float@ ( n -- op )
-    double-float-regs reg-size *
-    stack-frame get spill-float-base
-    + stack@ ;
-
 M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
 M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
 

basis/heaps/heaps.factor

@@ -192,6 +192,9 @@ M: heap heap-pop ( heap -- value key )
     [ dup heap-pop swap 2array ]
     produce nip ;
 
+: heap-values ( heap -- alist )
+    data>> [ value>> ] { } map-as ;
+
 : slurp-heap ( heap quot: ( elt -- ) -- )
     over heap-empty? [ 2drop ] [
         [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi

basis/images/authors.txt

@@ -1 +1,2 @@
 Doug Coleman
+Daniel Ehrenberg

basis/images/bitmap/bitmap.factor

@@ -1,61 +1,147 @@
 ! Copyright (C) 2007, 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types arrays byte-arrays columns
-combinators fry grouping io io.binary io.encodings.binary io.files
+combinators compression.run-length endian fry grouping images
-kernel macros math math.bitwise math.functions namespaces sequences
+images.loader io io.binary io.encodings.binary io.files
-strings images endian summary locals ;
+io.streams.limited kernel locals macros math math.bitwise
+math.functions namespaces sequences specialized-arrays.uint
+specialized-arrays.ushort strings summary io.encodings.8-bit
+io.encodings.string ;
+QUALIFIED-WITH: bitstreams b
 IN: images.bitmap
 
-: assert-sequence= ( a b -- )
-    2dup sequence= [ 2drop ] [ assert ] if ;
-
 : read2 ( -- n ) 2 read le> ;
 : read4 ( -- n ) 4 read le> ;
 : write2 ( n -- ) 2 >le write ;
 : write4 ( n -- ) 4 >le write ;
 
-TUPLE: bitmap-image < image ;
+SINGLETON: bitmap-image
-
+"bmp" bitmap-image register-image-class
-! Used to construct the final bitmap-image
 
 TUPLE: loading-bitmap 
-size reserved offset header-length width
+magic size reserved1 reserved2 offset header-length width
 height planes bit-count compression size-image
-x-pels y-pels color-used color-important rgb-quads color-index ;
+x-pels y-pels color-used color-important
+red-mask green-mask blue-mask alpha-mask
+cs-type end-points
+gamma-red gamma-green gamma-blue
+intent profile-data profile-size reserved3
+color-palette color-index bitfields ;
 
-ERROR: bitmap-magic magic ;
+! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint
-
-M: bitmap-magic summary
-    drop "First two bytes of bitmap stream must be 'BM'" ;
 
 <PRIVATE
 
-: 8bit>buffer ( bitmap -- array )
+: os2-color-lookup ( loading-bitmap -- seq )
-    [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
+    [ color-index>> >array ]
-    [ color-index>> >array ] bi [ swap nth ] with map concat ;
+    [ color-palette>> 3 <sliced-groups> ] bi
+    '[ _ nth ] map concat ;
+
+: os2v2-color-lookup ( loading-bitmap -- seq )
+    [ color-index>> >array ]
+    [ color-palette>> 3 <sliced-groups> ] bi
+    '[ _ nth ] map concat ;
+
+: v3-color-lookup ( loading-bitmap -- seq )
+    [ color-index>> >array ]
+    [ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
+    '[ _ nth ] map concat ;
+
+: color-lookup ( loading-bitmap -- seq )
+    dup header-length>> {
+        { 12 [ os2-color-lookup ] }
+        { 64 [ os2v2-color-lookup ] }
+        { 40 [ v3-color-lookup ] }
+        ! { 108 [ v4-color-lookup ] }
+        ! { 124 [ v5-color-lookup ] }
+    } case ;
 
 ERROR: bmp-not-supported n ;
 
-: reverse-lines ( byte-array width -- byte-array )
+: uncompress-bitfield ( seq masks -- bytes' )
-    <sliced-groups> <reversed> concat ; inline
+    '[
+        _ [
+            [ bitand ] [ bit-count ] [ log2 ] tri - shift
+        ] with map
+    ] { } map-as B{ } concat-as ;
 
-: raw-bitmap>seq ( loading-bitmap -- array )
+: bitmap>bytes ( loading-bitmap -- byte-array )
     dup bit-count>>
     {
         { 32 [ color-index>> ] }
-        { 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] }
+        { 24 [ color-index>> ] }
-        { 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] }
+        { 16 [
+            [
+                ! byte-array>ushort-array
+                2 group [ le> ] map
+                ! 5 6 5
+                ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
+                ! 5 5 5
+                { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
+            ] change-color-index
+            color-index>>
+        ] }
+        { 8 [ color-lookup ] }
+        { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
+        { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
         [ bmp-not-supported ]
     } case >byte-array ;
 
+: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+    dup bit-count>> {
+        { 16 [ dup color-palette>> 4 group [ le> ] map ] }
+        { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
+    } case reverse >>bitfields ;
+
+ERROR: unsupported-bitfield-widths n ;
+
+M: unsupported-bitfield-widths summary
+    drop "Bitmaps only support bitfield compression in 16/32bit images" ;
+
+: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+    set-bitfield-widths
+    dup bit-count>> {
+        { 16 [
+            dup bitfields>> '[
+                byte-array>ushort-array _ uncompress-bitfield
+            ] change-color-index
+        ] }
+        { 32 [
+            dup bitfields>> '[
+                byte-array>uint-array _ uncompress-bitfield
+            ] change-color-index
+        ] }
+        [ unsupported-bitfield-widths ]
+    } case ;
+
+ERROR: unsupported-bitmap-compression compression ;
+
+: uncompress-bitmap ( loading-bitmap -- loading-bitmap' )
+    dup compression>> {
+        { f [ ] }
+        { 0 [ ] }
+        { 1 [ [ run-length-uncompress ] change-color-index ] }
+        { 2 [ [ 4 b:byte-array-n>seq run-length-uncompress >byte-array ] change-color-index ] }
+        { 3 [ uncompress-bitfield-widths ] }
+        { 4 [ "jpeg" unsupported-bitmap-compression ] }
+        { 5 [ "png" unsupported-bitmap-compression ] }
+    } case ;
+
+: bitmap-padding ( width -- n )
+    3 * 4 mod 4 swap - 4 mod ; inline
+
+: loading-bitmap>bytes ( loading-bitmap -- byte-array )
+    uncompress-bitmap
+    bitmap>bytes ;
+
 : parse-file-header ( loading-bitmap -- loading-bitmap )
-    2 read "BM" assert-sequence=
+    2 read latin1 decode >>magic
     read4 >>size
-    read4 >>reserved
+    read2 >>reserved1
+    read2 >>reserved2
     read4 >>offset ;
 
-: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
+: read-v3-header ( loading-bitmap -- loading-bitmap )
-    read4 >>header-length
     read4 >>width
     read4 32 >signed >>height
     read2 >>planes
@@ -67,7 +153,51 @@ ERROR: bmp-not-supported n ;
     read4 >>color-used
     read4 >>color-important ;
 
-: rgb-quads-length ( loading-bitmap -- n )
+: read-v4-header ( loading-bitmap -- loading-bitmap )
+    read-v3-header
+    read4 >>red-mask
+    read4 >>green-mask
+    read4 >>blue-mask
+    read4 >>alpha-mask
+    read4 >>cs-type
+    read4 read4 read4 3array >>end-points
+    read4 >>gamma-red
+    read4 >>gamma-green
+    read4 >>gamma-blue ;
+
+: read-v5-header ( loading-bitmap -- loading-bitmap )
+    read-v4-header
+    read4 >>intent
+    read4 >>profile-data
+    read4 >>profile-size
+    read4 >>reserved3 ;
+
+: read-os2-header ( loading-bitmap -- loading-bitmap )
+    read2 >>width
+    read2 16 >signed >>height
+    read2 >>planes
+    read2 >>bit-count ;
+
+: read-os2v2-header ( loading-bitmap -- loading-bitmap )
+    read4 >>width
+    read4 32 >signed >>height
+    read2 >>planes
+    read2 >>bit-count ;
+
+ERROR: unknown-bitmap-header n ;
+
+: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
+    read4 [ >>header-length ] keep
+    {
+        { 12 [ read-os2-header ] }
+        { 64 [ read-os2v2-header ] }
+        { 40 [ read-v3-header ] }
+        { 108 [ read-v4-header ] }
+        { 124 [ read-v5-header ] }
+        [ unknown-bitmap-header ]
+    } case ;
+
+: color-palette-length ( loading-bitmap -- n )
     [ offset>> 14 - ] [ header-length>> ] bi - ;
 
 : color-index-length ( loading-bitmap -- n )
@@ -81,54 +211,54 @@ ERROR: bmp-not-supported n ;
 : image-size ( loading-bitmap -- n )
     [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
 
-: bitmap-padding ( width -- n )
-    3 * 4 mod 4 swap - 4 mod ; inline
-
-:: fixup-color-index ( loading-bitmap -- loading-bitmap )
-    loading-bitmap width>> :> width
-    width 3 * :> width*3
-    loading-bitmap width>> bitmap-padding :> padding
-    loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride
-    loading-bitmap
-    padding 0 > [
-        [
-            stride <sliced-groups>
-            [ width*3 head-slice ] map concat
-        ] change-color-index
-    ] when ;
-
 : parse-bitmap ( loading-bitmap -- loading-bitmap )
-    dup rgb-quads-length read >>rgb-quads
+    dup color-palette-length read >>color-palette
-    dup color-index-length read >>color-index
+    dup size-image>> dup 0 > [
-    fixup-color-index ;
+        read >>color-index
+    ] [
+        drop dup color-index-length read >>color-index
+    ] if ;
 
-: load-bitmap-data ( path -- loading-bitmap )
+ERROR: unsupported-bitmap-file magic ;
-    binary [
+
+: load-bitmap ( path -- loading-bitmap )
+    binary stream-throws <limited-file-reader> [
         loading-bitmap new
-        parse-file-header parse-bitmap-header parse-bitmap
+        parse-file-header dup magic>> {
-    ] with-file-reader ;
+            { "BM" [ parse-bitmap-header parse-bitmap ] }
+            ! { "BA" [ parse-os2-bitmap-array ] }
+            ! { "CI" [ parse-os2-color-icon ] }
+            ! { "CP" [ parse-os2-color-pointer ] }
+            ! { "IC" [ parse-os2-icon ] }
+            ! { "PT" [ parse-os2-pointer ] }
+            [ unsupported-bitmap-file ]
+        } case 
+    ] with-input-stream ;
 
 ERROR: unknown-component-order bitmap ;
 
 : bitmap>component-order ( loading-bitmap -- object )
     bit-count>> {
-        { 32 [ BGRA ] }
+        { 32 [ BGR ] }
         { 24 [ BGR ] }
+        { 16 [ BGR ] }
         { 8 [ BGR ] }
+        { 4 [ BGR ] }
+        { 1 [ BGR ] }
         [ unknown-component-order ]
     } case ;
 
-: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image )
+M: bitmap-image load-image* ( path bitmap-image -- bitmap )
+    drop load-bitmap
+    [ image new ] dip
     {
-        [ raw-bitmap>seq >>bitmap ]
+        [ loading-bitmap>bytes >>bitmap ]
         [ [ width>> ] [ height>> abs ] bi 2array >>dim ]
-        [ height>> 0 < [ t >>upside-down? ] when ]
+        [ height>> 0 < not >>upside-down? ]
+        [ compression>> 3 = [ t >>upside-down? ] when ]
         [ bitmap>component-order >>component-order ]
     } cleave ;
 
-M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
-    swap load-bitmap-data loading-bitmap>bitmap-image ;
-
 PRIVATE>
 
 : bitmap>color-index ( bitmap -- byte-array )
@@ -146,6 +276,9 @@ PRIVATE>
         ] if
     ] bi ;
 
+: reverse-lines ( byte-array width -- byte-array )
+    <sliced-groups> <reversed> concat ; inline
+
 : save-bitmap ( image path -- )
     binary [
         B{ CHAR: B CHAR: M } write
@@ -183,7 +316,7 @@ PRIVATE>
                 ! color-important
                 [ drop 0 write4 ]
 
-                ! rgb-quads
+                ! color-palette
                 [
                     [ bitmap>color-index ]
                     [ dim>> first 3 * ]

basis/images/images-tests.factor

@@ -0,0 +1,29 @@
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: images tools.test kernel accessors ;
+IN: images.tests
+
+[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA f B{
+    0 0 0 0 
+    0 0 0 0 
+    0 0 0 0 
+    57 57 57 255
+    0 0 0 0 
+    0 0 0 0 
+} } pixel-at ] unit-test
+
+[ B{
+    0 0 0 0 
+    0 0 0 0 
+    0 0 0 0 
+    57 57 57 255
+    0 0 0 0 
+    0 0 0 0 
+} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA f B{
+    0 0 0 0 
+    0 0 0 0 
+    0 0 0 0 
+    0 0 0 0 
+    0 0 0 0 
+    0 0 0 0 
+} } [ set-pixel-at ] keep bitmap>> ] unit-test

basis/images/images.factor

@@ -1,6 +1,6 @@
-! Copyright (C) 2009 Doug Coleman.
+! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel accessors ;
+USING: combinators kernel accessors sequences math arrays ;
 IN: images
 
 SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
@@ -34,4 +34,22 @@ 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 )
+
+<PRIVATE
+
+: pixel@ ( x y image -- start end bitmap )
+    [ dim>> first * + ]
+    [ component-order>> bytes-per-pixel [ * dup ] keep + ]
+    [ bitmap>> ] tri ;
+
+: set-subseq ( new-value from to victim -- )
+    <slice> 0 swap copy ; inline
+
+PRIVATE>
+
+: pixel-at ( x y image -- pixel )
+    pixel@ subseq ;
+
+: set-pixel-at ( pixel x y image -- )
+    pixel@ set-subseq ;

basis/images/jpeg/jpeg.factor

@@ -6,12 +6,14 @@ images.processing io io.binary io.encodings.binary io.files
 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 ;
+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

basis/images/loader/loader.factor

@@ -1,22 +1,24 @@
-! Copyright (C) 2009 Doug Coleman.
+! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: constructors kernel splitting unicode.case combinators
-accessors images.bitmap images.tiff images io.pathnames
+accessors images io.pathnames namespaces assocs ;
-images.png ;
 IN: images.loader
 
 ERROR: unknown-image-extension extension ;
 
+<PRIVATE
+
+SYMBOL: types
+types [ H{ } clone ] initialize
+
 : image-class ( path -- class )
-    file-extension >lower {
+    file-extension >lower types get ?at
-        { "bmp" [ bitmap-image ] }
+    [ unknown-image-extension ] unless ;
-        { "tif" [ tiff-image ] }
+
-        { "tiff" [ tiff-image ] }
+PRIVATE>
-        ! { "jpg" [ jpeg-image ] }
+
-        ! { "jpeg" [ jpeg-image ] }
+: register-image-class ( extension class -- )
-        { "png" [ png-image ] }
+    swap types get set-at ;
-        [ unknown-image-extension ]
-    } case ;
 
 : load-image ( path -- image )
-    dup image-class new load-image* ;
+    dup image-class load-image* ;

basis/images/png/png.factor

@@ -3,15 +3,19 @@
 USING: accessors constructors images io io.binary io.encodings.ascii
 io.encodings.binary io.encodings.string io.files io.files.info kernel
 sequences io.streams.limited fry combinators arrays math
-checksums checksums.crc32 compression.inflate grouping byte-arrays ;
+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 ;
 
@@ -103,9 +107,8 @@ ERROR: unimplemented-color-type image ;
     } case ;
 
 : load-png ( path -- image )
-    [ binary <file-reader> ] [ file-info size>> ] bi
+    binary stream-throws <limited-file-reader> [
-    stream-throws <limited-stream> [
+        <loading-png>
-        <png-image>
         read-png-header
         read-png-chunks
         parse-ihdr-chunk

basis/images/tiff/tiff.factor

@@ -5,13 +5,14 @@ compression.lzw constructors endian fry grouping images io
 io.binary io.encodings.ascii io.encodings.binary
 io.encodings.string io.encodings.utf8 io.files kernel math
 math.bitwise math.order math.parser pack prettyprint sequences
-strings math.vectors specialized-arrays.float locals ;
+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 ;
@@ -409,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>>
@@ -482,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 [ ] }
@@ -507,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
@@ -549,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
@@ -561,3 +550,5 @@ ERROR: unknown-component-order ifd ;
 ! tiff files can store several images -- we just take the first for now
 M: tiff-image load-image* ( path tiff-image -- image )
     drop load-tiff tiff>image ;
+
+{ "tif" "tiff" } [ tiff-image register-image-class ] each

basis/io/streams/limited/limited.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math io io.encodings destructors accessors
+USING: accessors byte-vectors combinators destructors fry io
-sequences namespaces byte-vectors fry combinators ;
+io.encodings io.files io.files.info kernel math namespaces
+sequences ;
 IN: io.streams.limited
 
 TUPLE: limited-stream stream count limit mode stack ;
@@ -16,6 +17,12 @@ SINGLETONS: stream-throws stream-eofs ;
         swap >>stream
         0 >>count ;
 
+: <limited-file-reader> ( path encoding mode -- stream' )
+    [
+        [ <file-reader> ]
+        [ drop file-info size>> ] 2bi
+    ] dip <limited-stream> ;
+
 GENERIC# limit 2 ( stream limit mode -- stream' )
 
 M: decoder limit ( stream limit mode -- stream' )

basis/math/bits/bits-docs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup math ;
+USING: help.syntax help.markup math sequences ;
 IN: math.bits
 
 ABOUT: "math.bits"
@@ -24,3 +24,7 @@ HELP: make-bits
     { $example "USING: math.bits prettyprint arrays ;" "BIN: 1101 make-bits >array ." "{ t f t t }" }
     { $example "USING: math.bits prettyprint arrays ;" "-3 make-bits >array ." "{ t f }" }
 } ;
+
+HELP: unbits
+{ $values { "seq" sequence } { "number" integer } }
+{ $description "Turns a sequence of booleans, of the same format made by the " { $link bits } " class, and calculates the number that it represents as little-endian." } ;

basis/math/bits/bits-tests.factor

@@ -29,3 +29,6 @@ IN: math.bits.tests
 [ t ] [
     1067811677921310779 >bignum make-bits last
 ] unit-test
+
+[ 6 ] [ 6 make-bits unbits ] unit-test
+[ 6 ] [ 6 3 <bits> >array unbits ] unit-test

basis/math/bits/bits.factor

@@ -14,3 +14,6 @@ M: bits length length>> ;
 M: bits nth-unsafe number>> swap bit? ;
 
 INSTANCE: bits immutable-sequence
+
+: unbits ( seq -- number )
+    <reversed> 0 [ [ 1 shift ] dip [ 1+ ] when ] reduce ;

basis/opengl/gl/gl.factor

@@ -1872,7 +1872,7 @@ GL-FUNCTION: void glUniform4uivEXT { } ( GLint location, GLsizei count, GLuint*
 GL-FUNCTION: void glGetUniformuivEXT { } ( GLuint program, GLint location, GLuint* params ) ;
 
 GL-FUNCTION: void glBindFragDataLocationEXT { } ( GLuint program, GLuint colorNumber, GLchar* name ) ;
-GL-FUNCTION: GLint GetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
+GL-FUNCTION: GLint glGetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
 
 CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER_EXT HEX: 88FD
 CONSTANT: GL_SAMPLER_1D_ARRAY_EXT HEX: 8DC0

basis/ui/gadgets/worlds/worlds.factor

@@ -217,4 +217,3 @@ M: world check-world-pixel-format
 : with-world-pixel-format ( world quot -- )
     [ dup dup world-pixel-format-attributes <pixel-format> ]
     dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline
-

basis/ui/images/images.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces cache images images.loader accessors assocs
 kernel opengl opengl.gl opengl.textures ui.gadgets.worlds
-memoize ;
+memoize images.tiff ;
 IN: ui.images
 
 TUPLE: image-name path ;

basis/ui/ui.factor

@@ -206,8 +206,11 @@ PRIVATE>
 : open-world-window ( world -- )
     dup pref-dim >>dim dup relayout graft ;
 
+: open-window* ( gadget title/attributes -- window )
+    ?attributes <world> [ open-world-window ] keep ;
+
 : open-window ( gadget title/attributes -- )
-    ?attributes <world> open-world-window ;
+    open-window* drop ;
 
 : set-fullscreen ( gadget ? -- )
     [ find-world ] dip (set-fullscreen) ;

extra/game-loop/game-loop.factor

@@ -1,5 +1,5 @@
-USING: accessors calendar destructors kernel math math.order namespaces
+USING: accessors calendar continuations destructors kernel math
-system threads ;
+math.order namespaces system threads ui ui.gadgets.worlds ;
 IN: game-loop
 
 TUPLE: game-loop
@@ -27,6 +27,16 @@ SYMBOL: game-loop
 
 CONSTANT: MAX-FRAMES-TO-SKIP 5
 
+DEFER: stop-loop
+
+TUPLE: game-loop-error game-loop error ;
+
+: ?ui-error ( error -- )
+    ui-running? [ ui-error ] [ rethrow ] if ;
+
+: game-loop-error ( game-loop error -- )
+    [ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;
+
 <PRIVATE
 
 : redraw ( loop -- )
@@ -54,7 +64,9 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5
     [ drop ] if ;
 
 : run-loop ( loop -- )
-    dup game-loop [ (run-loop) ] with-variable ;
+    dup game-loop
+    [ [ (run-loop) ] [ game-loop-error ] recover ]
+    with-variable ;
 
 : benchmark-millis ( loop -- millis )
     millis swap benchmark-time>> - ;
@@ -91,3 +103,6 @@ PRIVATE>
 M: game-loop dispose
     stop-loop ;
 
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "game-loop.prettyprint" require ] when

extra/game-loop/prettyprint/prettyprint.factor

@@ -0,0 +1,9 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors debugger game-loop io ;
+IN: game-loop.prettyprint
+
+M: game-loop-error error.
+    "An error occurred inside a game loop." print
+    "The game loop has been stopped to prevent runaway errors." print
+    "The error was:" print nl
+    error>> error. ;

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

extra/managed-server/chat/chat.factor

@@ -126,7 +126,8 @@ M: chat-server handle-client-disconnect
     ] "" append-outputs-as send-everyone ;
 
 M: chat-server handle-already-logged-in
-    username username-taken-string send-line ;
+    username username-taken-string send-line
+    t client (>>quit?) ;
 
 M: chat-server handle-managed-client*
     readln dup f = [ t client (>>quit?) ] when

extra/managed-server/managed-server.factor

@@ -11,7 +11,7 @@ TUPLE: managed-server < threaded-server clients ;
 
 TUPLE: managed-client
 input-stream output-stream local-address remote-address
-username object quit? ;
+username object quit? logged-in? ;
 
 HOOK: handle-login threaded-server ( -- username )
 HOOK: handle-managed-client* managed-server ( -- )
@@ -62,26 +62,39 @@ PRIVATE>
         local-address get >>local-address
         remote-address get >>remote-address ;
 
-: check-logged-in ( username -- username )
+: maybe-login-client ( -- )
-    dup clients key? [ handle-already-logged-in ] when ;
+    username clients key? [
+        handle-already-logged-in
+    ] [
+        t client (>>logged-in?)
+        client username clients set-at
+    ] if ;
 
-: add-managed-client ( -- )
+: when-logged-in ( quot -- )
-    client username check-logged-in clients set-at ;
+    client logged-in?>> [ call ] [ drop ] if ; inline
 
 : delete-managed-client ( -- )
-    username server clients>> delete-at ;
+    [ username server clients>> delete-at ] when-logged-in ;
 
 : handle-managed-client ( -- )
     handle-login <managed-client> managed-client set
-    add-managed-client handle-client-join
+    maybe-login-client [
-    [ handle-managed-client* client quit?>> not ] loop ;
+        handle-client-join
+        [ handle-managed-client* client quit?>> not ] loop
+    ] when-logged-in ;
+
+: cleanup-client ( -- )
+    [
+        delete-managed-client
+        handle-client-disconnect
+    ] when-logged-in ;
 
 PRIVATE>
 
 M: managed-server handle-client*
     managed-server set
     [ handle-managed-client ]
-    [ delete-managed-client handle-client-disconnect ]
+    [ cleanup-client ]
     [ ] cleanup ;
 
 : new-managed-server ( port name encoding class -- server )

extra/ui/gadgets/worlds/null/null.factor

@@ -0,0 +1,27 @@
+USING: accessors kernel ui ui.backend ui.gadgets
+ui.gadgets.worlds ui.pixel-formats ;
+IN: ui.gadgets.worlds.null
+
+TUPLE: null-world < world ;
+M: null-world begin-world drop ;
+M: null-world end-world drop ;
+M: null-world draw-world* drop ;
+M: null-world resize-world drop ;
+M: null-world pref-dim* drop { 512 512 } ;
+
+: null-window ( title -- world )
+    <world-attributes>
+        swap >>title
+        null-world >>world-class
+        {
+            windowed
+            double-buffered
+            backing-store
+            T{ depth-bits f 24 }
+        } >>pixel-format-attributes
+    f swap open-window* ;
+
+: into-window ( world quot -- world )
+    [ dup handle>> ] dip with-gl-context ; inline
+
+

vm/data_gc.cpp

@@ -680,9 +680,15 @@ PRIMITIVE(become)
 	compile_all_words();
 }
 
-VM_C_API void minor_gc()
+VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size)
 {
+	for(cell i = 0; i < gc_roots_size; i++)
+		gc_local_push((cell)&gc_roots_base[i]);
+
 	garbage_collection(data->nursery(),false,0);
+
+	for(cell i = 0; i < gc_roots_size; i++)
+		gc_local_pop();
 }
 
 }

vm/data_gc.hpp

@@ -143,6 +143,6 @@ inline static void check_tagged_pointer(cell tagged)
 #endif
 }
 
-VM_C_API void minor_gc();
+VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size);
 
 }