ui.gadgets: ensure that layout-later yields if the queue gets to large

This improves memory utilization a lot for #1488. Otherwise the queue
grows to two million entries before being processed.

basis/ui/gadgets/gadgets-docs.factor

@@ -149,6 +149,10 @@ HELP: parents
 { $values { "gadget" gadget } { "seq" "a sequence of gadgets" } }
 { $description "Outputs a sequence of all parents of the gadget, with the first element being the gadget itself." } ;
 
+HELP: child?
+{ $values { "parent" gadget } { "child" gadget } { "?" boolean } }
+{ $description "Tests if " { $snippet "child" } " is contained inside " { $snippet "parent" } "." } ;
+
 HELP: each-parent
 { $values { "gadget" gadget } { "quot" { $quotation ( gadget -- ? ) } } { "?" boolean } }
 { $description "Applies the quotation to every parent of the gadget, starting from the gadget itself, stopping if the quotation yields " { $link f } ". Outputs " { $link t } " if the iteration completed, and outputs " { $link f } " if it was stopped prematurely." } ;
@@ -157,14 +161,6 @@ HELP: find-parent
 { $values { "gadget" gadget } { "quot" { $quotation ( gadget -- ? ) } } { "parent" gadget } }
 { $description "Outputs the first parent of the gadget, starting from the gadget itself, for which the quotation outputs a true value, or " { $link f } " if the quotation outputs " { $link f } " for every parent." } ;
 
-HELP: screen-loc
-{ $values { "gadget" gadget } { "loc" "a pair of integers" } }
-{ $description "Outputs the location of the gadget relative to the top-left corner of the world containing the gadget. This word does not output a useful value if the gadget is not grafted." } ;
-
-HELP: child?
-{ $values { "parent" gadget } { "child" gadget } { "?" boolean } }
-{ $description "Tests if " { $snippet "child" } " is contained inside " { $snippet "parent" } "." } ;
-
 HELP: focusable-child*
 { $values { "gadget" gadget } { "child/t" "a " { $link gadget } " or " { $link t } } }
 { $description "Outputs the child of the gadget which would prefer to receive keyboard focus, or " { $link t } " if the gadget itself should receive focus." }
@@ -176,6 +172,14 @@ HELP: focusable-child
 
 { control-value set-control-value } related-words
 
+HELP: layout-later
+{ $values { "gadget" gadget } }
+{ $description "Adds the gadget to the " { $link layout-queue } " and notifies the UI thread that there is a gadget to layout. If the length of the queue is larger than " { $link layout-queue-limit } ", then the current thread is yielded so that the UI thread has a chance to run." } ;
+
+HELP: screen-loc
+{ $values { "gadget" gadget } { "loc" "a pair of integers" } }
+{ $description "Outputs the location of the gadget relative to the top-left corner of the world containing the gadget. This word does not output a useful value if the gadget is not grafted." } ;
+
 HELP: set-control-value
 { $values { "value" object } { "control" gadget } }
 { $description "Sets the value of the control's model." } ;

basis/ui/gadgets/gadgets-tests.factor

@@ -1,7 +1,7 @@
-USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds
-tools.test namespaces models kernel dlists deques math
-math.parser ui sequences hashtables assocs io arrays prettyprint
-io.streams.string math.rectangles ui.gadgets.private sets generic ;
+USING: accessors arrays assocs concurrency.flags deques dlists io
+io.streams.string kernel math math.parser math.rectangles models
+namespaces prettyprint sequences sets threads tools.test ui ui.gadgets
+ui.gadgets.private ;
 IN: ui.gadgets.tests
 
 { { 300 300 } }
@@ -151,3 +151,18 @@ M: mock-gadget ungraft*
 
     { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
 ] with-string-writer print
+
+: fake-ui-loop ( -- )
+    ui-notify-flag get-global lower-flag ;
+
+ui-running? [
+    { f } [
+        ! Initially lowered
+        <dlist> \ layout-queue set-global
+        <flag> ui-notify-flag set-global
+
+        [ fake-ui-loop ] "Fake UI" spawn drop
+        8001 iota [ layout-later ] each
+        ui-notify-flag get-global value>>
+    ] unit-test
+] unless

basis/ui/gadgets/gadgets.factor

@@ -1,9 +1,8 @@
 ! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables kernel math namespaces
-make sequences quotations math.vectors combinators sorting
-binary-search vectors dlists deques models threads
-concurrency.flags math.order math.rectangles fry locals ;
+USING: accessors arrays binary-search combinators concurrency.flags
+deques dlists fry kernel locals make math math.order math.rectangles
+math.vectors models namespaces sequences threads vectors ;
 IN: ui.gadgets
 
 ! Values for orientation slot
@@ -137,13 +136,17 @@ SYMBOL: ui-notify-flag
 
 : forget-pref-dim ( gadget -- ) f >>pref-dim drop ;
 
-: layout-queue ( -- queue ) \ layout-queue get ;
+: layout-queue ( -- queue )
+    \ layout-queue get ;
+
+CONSTANT: layout-queue-limit 8000
 
 : layout-later ( gadget -- )
-    ! When unit testing gadgets without the UI running, the
-    ! invalid queue is not initialized and we simply ignore
-    ! invalidation requests.
-    layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
+    layout-queue [
+        [ push-back notify-ui-thread ] [ drop ] if*
+    ] [
+        dlist-length layout-queue-limit > [ yield ] when
+    ] bi ;
 
 : invalidate* ( gadget -- )
     \ invalidate* >>layout-state