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

basis/alien/structs/structs-docs.factor

@@ -23,11 +23,11 @@ $nl
 }
 "C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
 $nl
-"Arrays of C structures can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-STRUCT: } "." ;
+"Arrays of C structures can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
 
 ARTICLE: "c-unions" "C unions"
 "A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
 { $subsection POSTPONE: C-UNION: }
 "C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
 $nl
-"Arrays of C unions can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;
+"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;

basis/compiler/cfg/linear-scan/allocation/allocation.factor

@@ -25,7 +25,7 @@ IN: compiler.cfg.linear-scan.allocation
         _ add-use-position
     ] each ;
 
-: compute-free-pos ( new -- free-pos )
+: register-status ( new -- free-pos )
     dup free-positions
     [ inactive-positions ] [ active-positions ] [ nip ] 2tri
     >alist alist-max ;
@@ -45,7 +45,7 @@ IN: compiler.cfg.linear-scan.allocation
 
 : assign-register ( new -- )
     dup coalesce? [ coalesce ] [
-        dup compute-free-pos {
+        dup register-status {
             { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
             { [ 2dup register-available? ] [ register-available ] }
             [ register-partially-available ]

basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators fry hints kernel locals
-math sequences sets sorting splitting compiler.utilities
+math sequences sets sorting splitting compiler.utilities namespaces
 compiler.cfg.linear-scan.allocation.state
 compiler.cfg.linear-scan.allocation.splitting
 compiler.cfg.linear-scan.live-intervals ;
@@ -10,42 +10,79 @@ IN: compiler.cfg.linear-scan.allocation.spilling
 : find-use ( live-interval n quot -- elt )
     [ uses>> ] 2dip curry find nip ; inline
 
-: spill-existing? ( new existing -- ? )
-    #! Test if 'new' will be used before 'existing'.
-    over start>> '[ _ [ > ] find-use -1 or ] bi@ < ;
-
 : interval-to-spill ( active-intervals current -- live-interval )
     #! We spill the interval with the most distant use location.
-    start>> '[ dup _ [ >= ] find-use ] { } map>assoc
+    #! If an active interval has no more use positions, find-use
+    #! returns f. This occurs if the interval is a split. In
+    #! this case, we prefer to spill this interval always.
+    start>> '[ dup _ [ >= ] find-use 1/0. or ] { } map>assoc
     alist-max first ;
 
+ERROR: bad-live-ranges interval ;
+
+: check-ranges ( live-interval -- )
+    check-allocation? get [
+        dup ranges>> [ [ from>> ] [ to>> ] bi <= ] all?
+        [ drop ] [ bad-live-ranges ] if
+    ] [ drop ] if ;
+
+: trim-before-ranges ( live-interval n -- )
+    [ ranges>> ] [ uses>> last ] bi
+    [ '[ from>> _ <= ] filter-here ]
+    [ swap last (>>to) ]
+    2bi ;
+
+: trim-after-ranges ( live-interval n -- )
+    [ ranges>> ] [ uses>> first ] bi
+    [ '[ to>> _ >= ] filter-here ]
+    [ swap first (>>from) ]
+    2bi ;
+
 : split-for-spill ( live-interval n -- before after )
     split-interval
-    [
+    {
-        [ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
+        [ [ trim-before-ranges ] [ trim-after-ranges ] bi* ]
-        [ [ ranges>> first ] [ uses>> first ] bi >>from drop ] bi*
-    ]
         [ [ compute-start/end ] bi@ ]
+        [ [ check-ranges ] bi@ ]
         [ ]
-    2tri ;
+    } 2cleave ;
 
-: assign-spill ( before after -- before after )
+: assign-spill ( live-interval -- live-interval )
-    #! If it has been spilled already, reuse spill location.
+    dup reload-from>>
-    over reload-from>>
+    [ dup vreg>> reg-class>> next-spill-location ] unless*
-    [ over vreg>> reg-class>> next-spill-location ] unless*
+    >>spill-to ;
-    [ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
+
+: assign-reload ( before after -- before after )
+    over spill-to>> >>reload-from ;
 
 : split-and-spill ( new existing -- before after )
-    swap start>> split-for-spill assign-spill ;
+    swap start>> split-for-spill assign-spill assign-reload ;
+
+: reuse-register ( new existing -- )
+    [ nip delete-active ]
+    [ reg>> >>reg add-active ] 2bi ;
+
+: spill-existing? ( new existing -- ? )
+    #! Test if 'new' will be used before 'existing'.
+    over start>> '[ _ [ > ] find-use -1 or ] bi@ < ;
 
 : spill-existing ( new existing -- )
     #! Our new interval will be used before the active interval
     #! with the most distant use location. Spill the existing
     #! interval, then process the new interval and the tail end
     #! of the existing interval again.
-    [ nip delete-active ]
+    [ reuse-register ]
-    [ reg>> >>reg add-active ]
+    [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2bi ;
-    [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
+
+: spill-live-out? ( new existing -- ? )
+    [ start>> ] [ uses>> last ] bi* > ;
+
+: spill-live-out ( new existing -- )
+    #! The existing interval is never used again. Spill it and
+    #! re-use the register.
+    assign-spill
+    [ reuse-register ]
+    [ nip add-handled ] 2bi ;
 
 : spill-new ( new existing -- )
     #! Our new interval will be used after the active interval
@@ -55,6 +92,9 @@ IN: compiler.cfg.linear-scan.allocation.spilling
     [ dup split-and-spill add-unhandled ] dip spill-existing ;
 
 : assign-blocked-register ( new -- )
-    [ dup vreg>> active-intervals-for ] keep interval-to-spill
+    [ dup vreg>> active-intervals-for ] keep interval-to-spill {
-    2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
+        { [ 2dup spill-live-out? ] [ spill-live-out ] }
+        { [ 2dup spill-existing? ] [ spill-existing ] }
+        [ spill-new ]
+    } cond ;
 

basis/compiler/cfg/linear-scan/assignment/assignment.factor

@@ -50,8 +50,11 @@ ERROR: already-spilled ;
 : handle-spill ( live-interval -- )
     dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
 
+: first-split ( live-interval -- live-interval' )
+    dup split-before>> [ first-split ] [ ] ?if ;
+
 : next-interval ( live-interval -- live-interval' )
-    split-next>> dup split-before>> [ next-interval ] [ ] ?if ;
+    split-next>> first-split ;
 
 : insert-copy ( live-interval -- )
     {

basis/compiler/cfg/linear-scan/linear-scan-tests.factor

@@ -156,6 +156,31 @@ check-assignment? on
     } 0 split-for-spill [ f >>split-next ] bi@
 ] unit-test
 
+[
+    T{ live-interval
+       { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+       { 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 20 }
+       { end 30 }
+       { uses V{ 20 30 } }
+       { ranges V{ T{ live-range f 20 30 } } }
+    }
+] [
+    T{ live-interval
+       { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+       { start 0 }
+       { end 30 }
+       { uses V{ 0 20 30 } }
+       { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
+    } 10 split-for-spill [ f >>split-next ] bi@
+] unit-test
+
 [
     T{ live-interval
         { vreg T{ vreg { reg-class int-regs } { n 1 } } }
@@ -1419,7 +1444,7 @@ USING: math.private ;
     relevant-ranges intersect-live-ranges
 ] unit-test
 
-! compute-free-pos had problems because it used map>assoc where the sequence
+! register-status had problems because it used map>assoc where the sequence
 ! had multiple keys
 [ { 0 10 } ] [
     H{ { int-regs { 0 1 } } } registers set
@@ -1468,7 +1493,7 @@ USING: math.private ;
         { ranges V{ T{ live-range f 8 10 } } }
         { uses V{ 8 10 } }
     }
-    compute-free-pos
+    register-status
 ] unit-test
 
 ! Bug in live spill slots calculation
@@ -1531,18 +1556,16 @@ V{
 SYMBOL: linear-scan-result
 
 :: test-linear-scan-on-cfg ( regs -- )
-    [ ] [
     cfg new 0 get >>entry
     compute-predecessors
     compute-liveness
     dup reverse-post-order
     { { int-regs regs } } (linear-scan)
-        flatten-cfg 1array mr.
+    flatten-cfg 1array mr. ;
-    ] unit-test ;
 
 ! This test has a critical edge -- do we care about these?
 
-! { 1 2 } test-linear-scan-on-cfg
+! [ { 1 2 } test-linear-scan-on-cfg ] unit-test
 
 ! Bug in inactive interval handling
 ! [ rot dup [ -rot ] when ]
@@ -1619,7 +1642,7 @@ V{
 
 test-diamond
 
-{ 1 2 3 4 } test-linear-scan-on-cfg
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
 
 ! Similar to the above
 ! [ swap dup [ rot ] when ]
@@ -1705,7 +1728,7 @@ V{
 
 test-diamond
 
-{ 1 2 3 4 } test-linear-scan-on-cfg
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
 
 ! compute-live-registers was inaccurate since it didn't take
 ! lifetime holes into account
@@ -1758,7 +1781,7 @@ V{
 
 test-diamond
 
-{ 1 2 3 4 } test-linear-scan-on-cfg
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
 
 ! Inactive interval handling: splitting active interval
 ! if it fits in lifetime hole only partially
@@ -1791,7 +1814,7 @@ V{
 
 test-diamond
 
-{ 1 2 } test-linear-scan-on-cfg
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
 
 USING: classes ;
 
@@ -1830,7 +1853,7 @@ V{
 
 test-diamond
 
-{ 1 2 } test-linear-scan-on-cfg
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
 
 [ _spill ] [ 2 get instructions>> first class ] 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
-binary-search combinators compiler.cfg.instructions compiler.cfg.registers
+combinators compiler.cfg.instructions compiler.cfg.registers
 compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
 IN: compiler.cfg.linear-scan.live-intervals
 

basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor

@@ -40,11 +40,11 @@ T{ live-interval
 }
 
 [ f ] [
-    0 get test-live-interval-1 spill-to
+    test-live-interval-1 0 get spill-to
 ] unit-test
 
 [ 0 ] [
-    1 get test-live-interval-1 spill-to
+    test-live-interval-1 1 get spill-to
 ] unit-test
 
 CONSTANT: test-live-interval-2
@@ -58,11 +58,11 @@ T{ live-interval
 }
 
 [ 0 ] [
-    0 get test-live-interval-2 reload-from
+    test-live-interval-2 0 get reload-from
 ] unit-test
 
 [ f ] [
-    1 get test-live-interval-2 reload-from
+    test-live-interval-2 1 get reload-from
 ] unit-test
 
 [
@@ -136,10 +136,14 @@ T{ live-interval
 ] unit-test
 
 [
-    { T{ _spill { src 4 } { class int-regs } { n spill-temp } } }
+    {
+        T{ _spill { src 3 } { class int-regs } { n 4 } }
+        T{ _reload { dst 2 } { class int-regs } { n 1 } } 
+    }
 ] [
     {
-       T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
+       T{ register->memory { from 3 } { to 4 } { reg-class int-regs } }
+       T{ memory->register { from 1 } { to 2 } { reg-class int-regs } }
     } mapping-instructions
 ] unit-test
 

basis/compiler/cfg/linear-scan/resolve/resolve.factor

@@ -25,13 +25,16 @@ SYNTAX: OPERATION:
 
 >>
 
-: reload-from ( bb live-interval -- n/f )
+: insn-in-block? ( insn# bb -- ? )
-    2dup [ block-from ] [ start>> ] bi* =
+    [ block-from ] [ block-to ] bi between? ;
-    [ nip reload-from>> ] [ 2drop f ] if ;
 
-: spill-to ( bb live-interval -- n/f )
+: reload-from ( live-interval bb -- n/f )
-    2dup [ block-to ] [ end>> ] bi* =
+    2dup [ start>> ] dip insn-in-block?
-    [ nip spill-to>> ] [ 2drop f ] if ;
+    [ drop reload-from>> ] [ 2drop f ] if ;
+
+: spill-to ( live-interval bb -- n/f )
+    2dup [ end>> ] dip insn-in-block?
+    [ drop spill-to>> ] [ 2drop f ] if ;
 
 OPERATION: memory->memory spill-to>> reload-from>>
 OPERATION: register->memory reg>> reload-from>>
@@ -39,12 +42,12 @@ OPERATION: memory->register spill-to>> reg>>
 OPERATION: register->register reg>> reg>>
 
 :: add-mapping ( bb1 bb2 li1 li2 -- )
-    bb2 li2 reload-from [
+    li2 bb2 reload-from [
-        bb1 li1 spill-to
+        li1 bb1 spill-to
         [ li1 li2 memory->memory ]
         [ li1 li2 register->memory ] if
     ] [
-        bb1 li1 spill-to
+        li1 bb1 spill-to
         [ li1 li2 memory->register ]
         [ li1 li2 register->register ] if
     ] if ;
@@ -68,10 +71,10 @@ M: memory->memory >insn
     [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
 
 M: register->memory >insn
-    [ from>> ] [ reg-class>> ] bi spill-temp _spill ;
+    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
 
 M: memory->register >insn
-    [ to>> ] [ reg-class>> ] bi spill-temp _reload ;
+    [ to>> ] [ reg-class>> ] [ from>> ] tri  _reload ;
 
 M: register->register >insn
     [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
@@ -82,10 +85,10 @@ M: memory->memory >collision-table
     [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
 
 M: register->memory >collision-table
-    [ from>> ] [ reg-class>> ] bi spill-temp _spill ;
+    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
 
 M: memory->register >collision-table
-    [ to>> ] [ reg-class>> ] bi spill-temp _reload ;
+    [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
 
 M: register->register >collision-table
     [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;

basis/compiler/tree/optimizer/optimizer.factor

@@ -20,7 +20,6 @@ SYMBOL: check-optimizer?
 
 : ?check ( nodes -- nodes' )
     check-optimizer? get [
-        compute-def-use
         dup check-nodes
     ] when ;
 

basis/images/images.factor

@@ -23,7 +23,7 @@ UNION: component-order
     INTENSITY DEPTH DEPTH-STENCIL R RG ;
 
 UNION: component-type
-    ubyte-components ushort-components
+    ubyte-components ushort-components uint-components
     half-components float-components
     byte-integer-components ubyte-integer-components
     short-integer-components ushort-integer-components
@@ -40,6 +40,16 @@ UNION: unnormalized-integer-components
     short-integer-components ushort-integer-components
     int-integer-components uint-integer-components ;
 
+UNION: signed-unnormalized-integer-components
+    byte-integer-components 
+    short-integer-components 
+    int-integer-components ;
+
+UNION: unsigned-unnormalized-integer-components
+    ubyte-integer-components
+    ushort-integer-components
+    uint-integer-components ;
+
 UNION: packed-components
     u-5-5-5-1-components u-5-6-5-components
     u-10-10-10-2-components
@@ -109,13 +119,15 @@ GENERIC: load-image* ( path class -- image )
         { RG [ 2 ] }
     } case ;
 
-: bytes-per-pixel ( image -- n )
+: (bytes-per-pixel) ( component-order component-type -- n )
-    dup component-type>> packed-components?
+    dup packed-components?
-    [ component-type>> bytes-per-packed-pixel ] [
+    [ nip bytes-per-packed-pixel ] [
-        [ component-order>> component-count ]
+        [ component-count ] [ bytes-per-component ] bi* *
-        [ component-type>>  bytes-per-component ] bi *
     ] if ;
 
+: bytes-per-pixel ( image -- n )
+    [ component-order>> ] [ component-type>> ] bi (bytes-per-pixel) ;
+
 <PRIVATE
 
 : pixel@ ( x y image -- start end bitmap )

basis/opengl/opengl.factor

@@ -128,12 +128,12 @@ MACRO: all-enabled-client-state ( seq quot -- )
 : (gen-gl-object) ( quot -- id )
     [ 1 0 <uint> ] dip keep *uint ; inline
 
-: gen-gl-buffer ( -- id )
-    [ glGenBuffers ] (gen-gl-object) ;
-
 : (delete-gl-object) ( id quot -- )
     [ 1 swap <uint> ] dip call ; inline
 
+: gen-gl-buffer ( -- id )
+    [ glGenBuffers ] (gen-gl-object) ;
+
 : delete-gl-buffer ( id -- )
     [ glDeleteBuffers ] (delete-gl-object) ;
 
@@ -146,6 +146,16 @@ MACRO: all-enabled-client-state ( seq quot -- )
         GL_ARRAY_BUFFER swap _ with-gl-buffer
     ] with-gl-buffer ; inline
 
+: gen-vertex-array ( -- id )
+    [ glGenVertexArrays ] (gen-gl-object) ;
+
+: delete-vertex-array ( id -- )
+    [ glDeleteVertexArrays ] (delete-gl-object) ;
+
+:: with-vertex-array ( id quot -- )
+    id glBindVertexArray
+    quot [ 0 glBindVertexArray ] [ ] cleanup ; inline
+
 : <gl-buffer> ( target data hint -- id )
     pick gen-gl-buffer [
         [

basis/specialized-arrays/alien/alien.factor

@@ -2,3 +2,4 @@ USE: specialized-arrays.functor
 IN: specialized-arrays.alien
 
 << "void*" define-array >>
+<< "ptrdiff_t" define-array >>

basis/ui/backend/backend.factor

@@ -27,10 +27,6 @@ GENERIC: flush-gl-context ( handle -- )
 
 HOOK: offscreen-pixels ui-backend ( world -- alien w h )
 
-: with-gl-context ( handle quot -- )
-    '[ select-gl-context @ ]
-    [ flush-gl-context gl-error ] bi ; inline
-
 HOOK: (with-ui) ui-backend ( quot -- )
 
 HOOK: (grab-input) ui-backend ( handle -- )

basis/ui/gadgets/worlds/worlds-docs.factor

@@ -1,6 +1,6 @@
 USING: ui.gadgets ui.render ui.text ui.text.private
 ui.gestures ui.backend help.markup help.syntax
-models opengl sequences strings ;
+models opengl sequences strings destructors ;
 IN: ui.gadgets.worlds
 
 HELP: user-input
@@ -29,10 +29,17 @@ HELP: set-title
 { $description "Sets the title bar of the native window containing the world." }
 { $notes "This word should not be called directly by user code. Instead, change the " { $snippet "title" } " slot model; see " { $link "models" } "." } ;
 
-HELP: select-gl-context
+HELP: context-world
-{ $values { "handle" "a backend-specific handle" } }
+{ $var-description "Holds the " { $link world } " whose OpenGL context was most recently made active by " { $link set-gl-context } "." } ;
+
+HELP: set-gl-context
+{ $values { "world" world } }
 { $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ;
 
+HELP: window-resource
+{ $values { "resource" disposable } { "resource" disposable } }
+{ $description "Marks " { $snippet "resource" } " to be destroyed with " { $link dispose } " when the window with the currently active OpenGL context (set by " { $link set-gl-context } ") is closed. " { $snippet "resource" } " is left unmodified at the top of the stack." } ;
+
 HELP: flush-gl-context
 { $values { "handle" "a backend-specific handle" } }
 { $description "Ensures all GL rendering calls made to an OpenGL context finish rendering to the screen. This word is called automatically by the UI after drawing a " { $link world } "." } ;

basis/ui/gadgets/worlds/worlds.factor

@@ -34,7 +34,8 @@ TUPLE: world < track
     text-handle handle images
     window-loc
     pixel-format-attributes
-    window-controls ;
+    window-controls
+    window-resources ;
 
 TUPLE: world-attributes
     { world-class initial: world }
@@ -77,11 +78,24 @@ TUPLE: world-attributes
         '[ f _ [ (>>status-owner) ] [ status>> set-model ] 2bi ] when
     ] [ 2drop ] if ;
 
+SYMBOL: context-world
+
+: window-resource ( resource -- resource )
+    dup context-world get-global window-resources>> push ;
+
+: set-gl-context ( world -- )
+    [ context-world set-global ]
+    [ handle>> select-gl-context ] bi ;
+
+: with-gl-context ( world quot -- )
+    '[ set-gl-context @ ]
+    [ handle>> flush-gl-context gl-error ] bi ; inline
+
 ERROR: no-world-found ;
 
 : find-gl-context ( gadget -- )
     find-world dup
-    [ handle>> select-gl-context ] [ no-world-found ] if ;
+    [ set-gl-context ] [ no-world-found ] if ;
 
 : (request-focus) ( child world ? -- )
     pick parent>> pick eq? [
@@ -98,7 +112,8 @@ M: world request-focus-on ( child gadget -- )
         t >>root?
         f >>active?
         { 0 0 } >>window-loc
-        f >>grab-input? ;
+        f >>grab-input?
+        V{ } clone >>window-resources ;
 
 : apply-world-attributes ( world attributes -- world )
     {
@@ -149,8 +164,8 @@ M: world (>>dim)
     [ call-next-method ]
     [
         dup handle>>
-        [ select-gl-context resize-world ]
+        [ [ set-gl-context ] [ resize-world ] bi ]
-        [ drop ] if*
+        [ drop ] if
     ] bi ;
 
 GENERIC: draw-world* ( world -- )
@@ -184,7 +199,7 @@ ui-error-hook [ [ rethrow ] ] initialize
     dup draw-world? [
         dup world [
             [
-                dup handle>> [ draw-world* ] with-gl-context
+                dup [ draw-world* ] with-gl-context
                 flush-layout-cache-hook get call( -- )
             ] [
                 over <world-error> ui-error

basis/ui/ui.factor

@@ -61,7 +61,7 @@ SYMBOL: windows
 
 : set-up-window ( world -- )
     {
-        [ handle>> select-gl-context ]
+        [ set-gl-context ]
         [ [ title>> ] keep set-title ]
         [ begin-world ]
         [ resize-world ]
@@ -89,12 +89,13 @@ M: world graft*
 
 : (ungraft-world) ( world -- )
     {
-        [ handle>> select-gl-context ]
+        [ set-gl-context ]
         [ text-handle>> [ dispose ] when* ]
         [ images>> [ dispose ] when* ]
         [ hand-clicked close-global ]
         [ hand-gadget close-global ]
         [ end-world ]
+        [ [ [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
     } cleave ;
 
 M: world ungraft*

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

@@ -22,6 +22,6 @@ M: null-world pref-dim* drop { 512 512 } ;
     f swap open-window* ;
 
 : into-window ( world quot -- world )
-    [ dup handle>> ] dip with-gl-context ; inline
+    [ dup ] dip with-gl-context ; inline