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

2009-05-10 21:33:13 -05:00 · 2009-05-10 21:33:13 -05:00 · 9de34ab3cd
parent 05e0171dea
commit 9de34ab3cd
10 changed files with 87 additions and 50 deletions
--- a/basis/cocoa/messages/messages.factor
+++ b/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

--- a/basis/tools/deploy/deploy-docs.factor
+++ b/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" }
--- a/basis/tools/deploy/deploy-tests.factor
+++ b/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? [
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/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
-namespaces make assocs kernel parser lexer strings.parser vocabs
-sequences words memory kernel.private
-continuations io vocabs.loader system strings sets
-vectors quotations byte-arrays sorting compiler.units
-definitions generic generic.standard tools.deploy.config ;
+USING: arrays accessors io.backend io.streams.c init fry namespaces
+make assocs kernel parser lexer strings.parser vocabs sequences words
+memory kernel.private continuations io vocabs.loader system strings
+sets vectors quotations byte-arrays sorting compiler.units definitions
+generic generic.standard tools.deploy.config combinators classes ;
 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
-                classes:class-and-cache
-                classes:class-not-cache
-                classes:class-or-cache
-                classes:class<=-cache
-                classes:classes-intersect-cache
-                classes:implementors-map
-                classes:update-map
+                next-method-quot-cache
+                class-and-cache
+                class-not-cache
+                class-or-cache
+                class<=-cache
+                classes-intersect-cache
+                implementors-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 ( -- )
-    [ byte-array? ] [ ] "byte arrays" compress ;
+: compress-objects ( -- )
+    [
+        {
+            [ 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
-            dup next-method-quot "next-method-quot" set-word-prop
+            nip dup
+            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 -- )
--- a/basis/tools/deploy/shaker/strip-cocoa.factor
+++ b/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
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/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
--- a/basis/ui/gestures/gestures.factor
+++ b/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
-unicode.categories combinators.short-circuit ;
+sets columns fry deques ui.gadgets ui.gadgets.private ascii
+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}" ] }
-            { M+ [ "\u{option-key}" ] }
-            { S+ [ "\u{upwards-white-arrow}" ] }
-            { C+ [ "\u{up-arrowhead}" ] }
+            { A+ [ "\u002318" ] }
+            { M+ [ "\u002325" ] }
+            { S+ [ "\u0021e7" ] }
+            { C+ [ "\u002303" ] }
        } case
    ] map "" join ;

--- a/basis/ui/pixel-formats/pixel-formats.factor
+++ b/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
--- a/extra/spheres/deploy.factor
+++ b/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 }
 }
--- a/extra/terrain/deploy.factor
+++ b/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 }
+}