Fix deployment of UI apps and implement various tricks to make deployed images smaller

basis/cocoa/messages/messages.factor

@@ -68,7 +68,7 @@ MACRO: (send) ( selector super? -- quot )
     [ dup lookup-method ] dip
     [ make-prepare-send ] 2keep
     super-message-senders message-senders ? get at
-    '[ _ call _ execute ] ;
+    1quotation append ;
 
 : send ( receiver args... selector -- return... ) f (send) ; inline
 

basis/tools/deploy/deploy-docs.factor

@@ -29,6 +29,8 @@ ARTICLE: "tools.deploy.caveats" "Deploy tool caveats"
 "In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment."
 { $heading "Behavior of " { $link POSTPONE: execute( } }
 "Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-effect-unsafe } "."
+{ $heading "Behavior of " { $link POSTPONE: call-next-method } }
+"The " { $link POSTPONE: call-next-method } " word does not check if the input is of the right type in deployed applications."
 { $heading "Error reporting" }
 "If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages."
 { $heading "Choosing the right deploy flags" }

basis/tools/deploy/deploy-tests.factor

@@ -20,6 +20,10 @@ io.directories tools.deploy.test ;
 
 [ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test
 
+[ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test
+
+[ t ] [ "terrain" shake-and-bake 1600000 small-enough? ] unit-test
+
 [ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
 
 os macosx? [

basis/tools/deploy/shaker/shaker.factor

@@ -1,13 +1,11 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io.backend io.streams.c init fry
+USING: arrays accessors io.backend io.streams.c init fry namespaces
-namespaces make assocs kernel parser lexer strings.parser vocabs
+make assocs kernel parser lexer strings.parser vocabs sequences words
-sequences words memory kernel.private
+memory kernel.private continuations io vocabs.loader system strings
-continuations io vocabs.loader system strings sets
+sets vectors quotations byte-arrays sorting compiler.units definitions
-vectors quotations byte-arrays sorting compiler.units
+generic generic.standard tools.deploy.config combinators classes ;
-definitions generic generic.standard tools.deploy.config ;
 QUALIFIED: bootstrap.stage2
-QUALIFIED: classes
 QUALIFIED: command-line
 QUALIFIED: compiler.errors
 QUALIFIED: continuations
@@ -193,6 +191,11 @@ IN: tools.deploy.shaker
     strip-word-names? [ dup strip-word-names ] when
     2drop ;
 
+: strip-compiler-classes ( -- )
+    "Stripping compiler classes" show
+    "compiler" child-vocabs [ words ] map concat [ class? ] filter
+    [ dup implementors [ "methods" word-prop delete-at ] with each ] each ;
+
 : strip-default-methods ( -- )
     strip-debugger? [
         "Stripping default methods" show
@@ -255,14 +258,14 @@ IN: tools.deploy.shaker
             {
                 gensym
                 name>char-hook
-                classes:next-method-quot-cache
+                next-method-quot-cache
-                classes:class-and-cache
+                class-and-cache
-                classes:class-not-cache
+                class-not-cache
-                classes:class-or-cache
+                class-or-cache
-                classes:class<=-cache
+                class<=-cache
-                classes:classes-intersect-cache
+                classes-intersect-cache
-                classes:implementors-map
+                implementors-map
-                classes:update-map
+                update-map
                 command-line:main-vocab-hook
                 compiled-crossref
                 compiled-generic-crossref
@@ -334,8 +337,16 @@ IN: tools.deploy.shaker
     [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
     become ; inline
 
-: compress-byte-arrays ( -- )
+: compress-objects ( -- )
-    [ byte-array? ] [ ] "byte arrays" compress ;
+    [
+        {
+            [ dup array? [ empty? ] [ drop f ] if ]
+            [ byte-array? ]
+            [ string? ]
+            [ wrapper? ]
+        } cleave
+        or or or
+    ] [ ] "objects" compress ;
 
 : remain-compiled ( old new -- old new )
     #! Quotations which were formerly compiled must remain
@@ -349,12 +360,6 @@ IN: tools.deploy.shaker
     [ quotation? ] [ remain-compiled ] "quotations" compress
     [ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ;
 
-: compress-strings ( -- )
-    [ string? ] [ ] "strings" compress ;
-
-: compress-wrappers ( -- )
-    [ wrapper? ] [ ] "wrappers" compress ;
-
 SYMBOL: deploy-vocab
 
 : [:c] ( -- word ) ":c" "debugger" lookup ;
@@ -385,18 +390,23 @@ SYMBOL: deploy-vocab
     t "quiet" set-global
     f output-stream set-global ;
 
+: unsafe-next-method-quot ( method -- quot )
+    [ "method-class" word-prop ]
+    [ "method-generic" word-prop ] bi
+    next-method 1quotation ;
+
 : compute-next-methods ( -- )
     [ standard-generic? ] instances [
         "methods" word-prop [
-            nip
+            nip dup
-            dup next-method-quot "next-method-quot" set-word-prop
+            unsafe-next-method-quot
+            "next-method-quot" set-word-prop
         ] assoc-each
     ] each
     "vocab:tools/deploy/shaker/next-methods.factor" run-file ;
 
 : strip ( -- )
     init-stripper
-    strip-default-methods
     strip-libc
     strip-call
     strip-cocoa
@@ -404,14 +414,14 @@ SYMBOL: deploy-vocab
     compute-next-methods
     strip-init-hooks
     strip-c-io
+    strip-compiler-classes
+    strip-default-methods
     f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
     deploy-vocab get vocab-main deploy-boot-quot
     stripped-word-props
     stripped-globals strip-globals
-    compress-byte-arrays
+    compress-objects
     compress-quotations
-    compress-strings
-    compress-wrappers
     strip-words ;
 
 : deploy-error-handler ( quot -- )

basis/tools/deploy/shaker/strip-cocoa.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2007, 2008 Slava Pestov
+! Copyright (C) 2007, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs
 namespaces kernel kernel.private words compiler.units sequences
-init vocabs ;
+init vocabs memoize accessors ;
 IN: tools.deploy.shaker.cocoa
 
 : pool ( obj -- obj' ) \ pool get [ ] cache ;
@@ -42,3 +42,8 @@ H{ } clone \ pool [
         [ get values compile ] each
     ] bind
 ] with-variable
+
+\ make-prepare-send reset-memoized
+\ <selector> reset-memoized
+
+\ (send) def>> second clear-assoc

basis/ui/gadgets/worlds/worlds.factor

@@ -4,7 +4,7 @@ USING: accessors arrays assocs continuations kernel math models
 namespaces opengl opengl.textures sequences io combinators
 combinators.short-circuit fry math.vectors math.rectangles cache
 ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.commands ui.pixel-formats destructors literals ;
+ui.pixel-formats destructors literals ;
 IN: ui.gadgets.worlds
 
 CONSTANT: default-world-pixel-format-attributes

basis/ui/gestures/gestures.factor

@@ -3,8 +3,8 @@
 USING: accessors arrays assocs kernel math math.order models
 namespaces make sequences words strings system hashtables math.parser
 math.vectors classes.tuple classes boxes calendar alarms combinators
-sets columns fry deques ui.gadgets ui.gadgets.private unicode.case
+sets columns fry deques ui.gadgets ui.gadgets.private ascii
-unicode.categories combinators.short-circuit ;
+combinators.short-circuit ;
 IN: ui.gestures
 
 GENERIC: handle-gesture ( gesture gadget -- ? )
@@ -296,10 +296,10 @@ HOOK: modifiers>string os ( modifiers -- string )
 M: macosx modifiers>string
     [
         {
-            { A+ [ "\u{place-of-interest-sign}" ] }
+            { A+ [ "\u002318" ] }
-            { M+ [ "\u{option-key}" ] }
+            { M+ [ "\u002325" ] }
-            { S+ [ "\u{upwards-white-arrow}" ] }
+            { S+ [ "\u0021e7" ] }
-            { C+ [ "\u{up-arrowhead}" ] }
+            { C+ [ "\u002303" ] }
         } case
     ] map "" join ;
 

basis/ui/pixel-formats/pixel-formats.factor

@@ -1,6 +1,6 @@
 USING: accessors assocs classes destructors functors kernel
 lexer math parser sequences specialized-arrays.int ui.backend
-words.symbol ;
+words ;
 IN: ui.pixel-formats
 
 SYMBOLS:
@@ -71,7 +71,7 @@ GENERIC: >PFA ( attribute -- pfas )
 
 M: object >PFA
     drop { } ;
-M: symbol >PFA
+M: word >PFA
     TABLE at [ { } ] unless* ;
 M: pixel-format-attribute >PFA
     dup class TABLE at

extra/spheres/deploy.factor

@@ -1,14 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-reflection 1 }
-    { deploy-word-defs? f }
-    { deploy-word-props? f }
-    { deploy-name "Spheres" }
-    { deploy-compiler? t }
-    { deploy-math? t }
-    { deploy-io 1 }
-    { deploy-threads? t }
-    { "stop-after-last-window?" t }
     { deploy-ui? t }
+    { deploy-reflection 1 }
+    { deploy-unicode? f }
+    { deploy-math? t }
+    { deploy-io 2 }
     { deploy-c-types? f }
+    { deploy-name "Spheres" }
+    { deploy-word-props? f }
+    { deploy-word-defs? f }
+    { "stop-after-last-window?" t }
+    { deploy-compiler? t }
+    { deploy-threads? t }
 }

extra/terrain/deploy.factor

@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-ui? t }
+    { deploy-reflection 1 }
+    { deploy-unicode? f }
+    { deploy-math? t }
+    { deploy-io 2 }
+    { deploy-c-types? f }
+    { deploy-name "Terrain" }
+    { deploy-word-props? f }
+    { deploy-word-defs? f }
+    { "stop-after-last-window?" t }
+    { deploy-compiler? t }
+    { deploy-threads? t }
+}