Tree-shaker now computes which globals it needs to strip, not which ones it needs to keep

extra/tools/deploy/backend/backend.factor

@@ -34,31 +34,33 @@ IN: tools.deploy.backend
 
 : ?, [ , ] [ drop ] if ;
 
-: bootstrap-profile ( config -- profile )
+: bootstrap-profile ( -- profile )
     [
-        [
+        "math" deploy-math? get ?,
-            "math" deploy-math? get ?,
+        "compiler" deploy-compiler? get ?,
-            "compiler" deploy-compiler? get ?,
+        "ui" deploy-ui? get ?,
-            "ui" deploy-ui? get ?,
+        "io" native-io? ?,
-            "io" native-io? ?,
+    ] { } make ;
-        ] { } make
-    ] bind ;
 
-: staging-image-name ( profile -- name )
+: staging-image-name ( -- name )
-    "staging." swap bootstrap-profile "-" join ".image" 3append ;
+    "staging."
+    bootstrap-profile strip-word-names? [ "strip" add ] when
+    "-" join ".image" 3append ;
 
 : staging-command-line ( config -- flags )
     [
-        "-i=" my-boot-image-name append ,
+        [
+            "-i=" my-boot-image-name append ,
 
-        "-output-image=" over staging-image-name append ,
+            "-output-image=" staging-image-name append ,
 
-        "-include=" swap bootstrap-profile " " join append ,
+            "-include=" bootstrap-profile " " join append ,
 
-        "-no-stack-traces" ,
+            strip-word-names? [ "-no-stack-traces" , ] when
 
-        "-no-user-init" ,
+            "-no-user-init" ,
-    ] { } make ;
+        ] { } make
+    ] bind ;
 
 : run-factor ( vm flags -- )
     swap add* dup . run-with-output ; inline
@@ -68,16 +70,18 @@ IN: tools.deploy.backend
 
 : deploy-command-line ( image vocab config -- flags )
     [
-        "-i=" swap staging-image-name append ,
+        [
+            "-i=" staging-image-name append ,
 
-        "-run=tools.deploy.shaker" ,
+            "-run=tools.deploy.shaker" ,
 
-        "-deploy-vocab=" swap append ,
+            "-deploy-vocab=" swap append ,
 
-        "-output-image=" swap append ,
+            "-output-image=" swap append ,
 
-        "-no-stack-traces" ,
+            strip-word-names? [ "-no-stack-traces" , ] when
-    ] { } make ;
+        ] { } make
+    ] bind ;
 
 : make-deploy-image ( vm image vocab config -- )
     make-boot-image

extra/tools/deploy/config/config.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: vocabs.loader io.files io kernel sequences assocs
 splitting parser prettyprint namespaces math vocabs
-hashtables tools.browser ;
+hashtables tools.vocabs ;
 IN: tools.deploy.config
 
 SYMBOL: deploy-name

extra/tools/deploy/deploy-tests.factor

@@ -5,7 +5,7 @@ tools.deploy.backend math ;
 : shake-and-bake
     "." resource-path [
         vm
-        "hello.image" temp-file
+        "test.image" temp-file
         rot dup deploy-config make-deploy-image
     ] with-directory ;
 
@@ -15,8 +15,30 @@ tools.deploy.backend math ;
     "hello.image" temp-file file-length 500000 <=
 ] unit-test
 
+[ ] [ "sudoku" shake-and-bake ] unit-test
+
+[ t ] [
+    "hello.image" temp-file file-length 1500000 <=
+] unit-test
+
 [ ] [ "hello-ui" shake-and-bake ] unit-test
 
 [ t ] [
     "hello.image" temp-file file-length 2000000 <=
 ] unit-test
+
+[ ] [ "bunny" shake-and-bake ] unit-test
+
+[ t ] [
+    "hello.image" temp-file file-length 3000000 <=
+] unit-test
+
+[ ] [
+    "tools.deploy.test.1" shake-and-bake
+    vm "-i=" "test.image" temp-file append try-process
+] unit-test
+
+[ ] [
+    "tools.deploy.test.2" shake-and-bake
+    vm "-i=" "test.image" temp-file append try-process
+] unit-test

extra/tools/deploy/shaker/shaker.factor

@@ -1,11 +1,29 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces continuations.private kernel.private init
+USING: qualified io.streams.c init fry namespaces assocs kernel
-assocs kernel vocabs words sequences memory io system arrays
+parser tools.deploy.config vocabs sequences words words.private
-continuations math definitions mirrors splitting parser classes
+memory kernel.private continuations io prettyprint
-inspector layouts vocabs.loader prettyprint.config prettyprint
+vocabs.loader debugger system strings ;
-debugger io.streams.c io.streams.duplex io.files io.backend
+QUALIFIED: bootstrap.stage2
-quotations words.private tools.deploy.config compiler.units ;
+QUALIFIED: classes
+QUALIFIED: compiler.errors.private
+QUALIFIED: compiler.units
+QUALIFIED: continuations
+QUALIFIED: definitions
+QUALIFIED: init
+QUALIFIED: inspector
+QUALIFIED: io.backend
+QUALIFIED: io.nonblocking
+QUALIFIED: io.thread
+QUALIFIED: layouts
+QUALIFIED: libc.private
+QUALIFIED: libc.private
+QUALIFIED: listener
+QUALIFIED: prettyprint.config
+QUALIFIED: random.private
+QUALIFIED: source-files
+QUALIFIED: threads
+QUALIFIED: vocabs
 IN: tools.deploy.shaker
 
 : strip-init-hooks ( -- )
@@ -43,9 +61,6 @@ IN: tools.deploy.shaker
         run-file
     ] when ;
 
-: strip-assoc ( retained-keys assoc -- newassoc )
-    swap [ nip member? ] curry assoc-subset ;
-
 : strip-word-names ( words -- )
     "Stripping word names" show
     [ f over set-word-name f swap set-word-vocabulary ] each ;
@@ -57,8 +72,11 @@ IN: tools.deploy.shaker
 : strip-word-props ( retain-props words -- )
     "Stripping word properties" show
     [
-        [ word-props strip-assoc f assoc-like ] keep
+        [
-        set-word-props
+            word-props swap
+            '[ , nip member? ] assoc-subset
+            f assoc-like
+        ] keep set-word-props
     ] with each ;
 
 : retained-props ( -- seq )
@@ -81,10 +99,101 @@ IN: tools.deploy.shaker
     strip-word-names? [ dup strip-word-names ] when
     2drop ;
 
-: strip-environment ( retain-globals -- )
+: strip-recompile-hook ( -- )
+    [ [ f ] { } map>assoc ]
+    compiler.units:recompile-hook
+    set-global ;
+
+: strip-vocab-globals ( except names -- words )
+    [ child-vocabs [ words ] map concat ] map concat seq-diff ;
+
+: stripped-globals ( -- seq )
+    [
+        random.private:mt ,
+
+        {
+            bootstrap.stage2:bootstrap-time
+            continuations:error
+            continuations:error-continuation
+            continuations:error-thread
+            continuations:restarts
+            error-hook
+            init:init-hooks
+            inspector:inspector-hook
+            io.thread:io-thread
+            libc.private:mallocs
+            source-files:source-files
+            stderr
+            stdio
+        } %
+
+        deploy-threads? [
+            threads:initial-thread ,
+        ] unless
+
+        strip-io? [ io.backend:io-backend , ] when
+
+        { io.backend:io-backend io.nonblocking:default-buffer-size }
+        { "alarms" "io" "tools" } strip-vocab-globals %
+
+        strip-dictionary? [
+            { } { "cpu" } strip-vocab-globals %
+
+            {
+                vocabs:dictionary
+                lexer-factory
+                vocabs:load-vocab-hook
+                layouts:num-tags
+                layouts:num-types
+                layouts:tag-mask
+                layouts:tag-numbers
+                layouts:type-numbers
+                classes:typemap
+                vocab-roots
+                definitions:crossref
+                compiled-crossref
+                interactive-vocabs
+                word
+                compiler.units:recompile-hook
+                listener:listener-hook
+                lexer-factory
+                classes:update-map
+                classes:class<map
+            } %
+        ] when
+
+        strip-prettyprint? [
+            {
+                prettyprint.config:margin
+                prettyprint.config:string-limit
+                prettyprint.config:tab-size
+            } %
+        ] when
+
+        strip-debugger? [
+            {
+                compiler.errors.private:compiler-errors
+                continuations:thread-error-hook
+            } %
+        ] when
+
+        deploy-c-types? get [
+            "c-types" "alien.c-types" lookup ,
+        ] unless
+
+        deploy-ui? get [
+            "ui-error-hook" "ui.gadgets.worlds" lookup ,
+        ] when
+    ] { } make ;
+
+: strip-globals ( stripped-globals -- )
     strip-globals? [
-        "Stripping environment" show
+        "Stripping globals" show
-        global strip-assoc 21 setenv
+        global swap
+        '[ drop , member? not ] assoc-subset
+        [ drop string? not ] assoc-subset ! strip CLI args
+        dup keys .
+        21 setenv
     ] [ drop ] if ;
 
 : finish-deploy ( final-image -- )
@@ -108,55 +217,6 @@ SYMBOL: deploy-vocab
     ] [ ] make "Boot quotation: " write dup . flush
     set-boot-quot ;
 
-: retained-globals ( -- seq )
-    [
-        builtins ,
-        strip-io? [ io-backend , ] unless
-
-        strip-dictionary? [
-            {
-                dictionary
-                inspector-hook
-                lexer-factory
-                load-vocab-hook
-                num-tags
-                num-types
-                tag-bits
-                tag-mask
-                tag-numbers
-                typemap
-                vocab-roots
-            } %
-        ] unless
-
-        strip-prettyprint? [
-            {
-                tab-size
-                margin
-            } %
-        ] unless
-
-        deploy-c-types? get [
-            "c-types" "alien.c-types" lookup ,
-        ] when
-
-        native-io? [
-            "default-buffer-size" "io.nonblocking" lookup ,
-        ] when
-
-        deploy-ui? get [
-            "ui" child-vocabs
-            "cocoa" child-vocabs
-            deploy-vocab get child-vocabs 3append
-            global keys [ word? ] subset
-            swap [ >r word-vocabulary r> member? ] curry
-            subset %
-        ] when
-    ] { } make dup . ;
-
-: strip-recompile-hook ( -- )
-    [ [ f ] { } map>assoc ] recompile-hook set-global ;
-
 : strip ( -- )
     strip-libc
     strip-cocoa
@@ -165,7 +225,7 @@ SYMBOL: deploy-vocab
     strip-init-hooks
     deploy-vocab get vocab-main set-boot-quot*
     retained-props >r
-    retained-globals strip-environment
+    stripped-globals strip-globals
     r> strip-words ;
 
 : (deploy) ( final-image vocab config -- )

extra/tools/deploy/test/1/1.factor

@@ -0,0 +1,6 @@
+IN: tools.deploy.test.1
+USING: threads ;
+
+: deploy-test-1 1000 sleep ;
+
+MAIN: deploy-test-1

extra/tools/deploy/test/1/deploy.factor

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

extra/tools/deploy/test/2/2.factor

@@ -0,0 +1,6 @@
+IN: tools.deploy.test.2
+USING: calendar calendar.format ;
+
+: deploy-test-2 now (timestamp>string) ;
+
+MAIN: deploy-test-2

extra/tools/deploy/test/2/deploy.factor

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

extra/tools/deploy/test/3/3.factor

@@ -0,0 +1,8 @@
+IN: tools.deploy.test.3
+USING: io.encodings.ascii io.files kernel ;
+
+: deploy-test-3
+    "resource:extra/tools/deploy/test/3/3.factor"
+    ?resource-path ascii file-contents drop ;
+
+MAIN: deploy-test-3

extra/tools/deploy/test/3/deploy.factor

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