Deployment fixes; add unit test which ensures deploy images are not too large

extra/tools/deploy/config/config-docs.factor

@@ -66,6 +66,11 @@ HELP: deploy-math?
 $nl
 "On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
 
+HELP: deploy-threads?
+{ $description "Deploy flag. If set, the deployed image will contain support for threads."
+$nl
+"On by default. Often the programmer will use threads without realizing it. A small amount of space can be saved by stripping this feature out, but some code may require changes to work properly." } ;
+
 HELP: deploy-compiler?
 { $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible."
 $nl

extra/tools/deploy/config/config.factor

@@ -10,6 +10,7 @@ SYMBOL: deploy-name
 SYMBOL: deploy-ui?
 SYMBOL: deploy-compiler?
 SYMBOL: deploy-math?
+SYMBOL: deploy-threads?
 
 SYMBOL: deploy-io
 
@@ -55,6 +56,7 @@ SYMBOL: deploy-image
         { deploy-io                 2 }
         { deploy-reflection         1 }
         { deploy-compiler?          t }
+        { deploy-threads?           t }
         { deploy-math?              t }
         { deploy-word-props?        f }
         { deploy-word-defs?         f }

extra/tools/deploy/deploy-tests.factor

@@ -0,0 +1,22 @@
+IN: temporary
+USING: tools.test system io.files kernel tools.deploy.config
+tools.deploy.backend math ;
+
+: shake-and-bake
+    "." resource-path [
+        vm
+        "hello.image" temp-file
+        rot dup deploy-config make-deploy-image
+    ] with-directory ;
+
+[ ] [ "hello-world" shake-and-bake ] unit-test
+
+[ t ] [
+    "hello.image" temp-file file-length 500000 <=
+] unit-test
+
+[ ] [ "hello-ui" shake-and-bake ] unit-test
+
+[ t ] [
+    "hello.image" temp-file file-length 2000000 <=
+] unit-test

extra/tools/deploy/shaker/shaker.factor

@@ -11,8 +11,16 @@ IN: tools.deploy.shaker
 : strip-init-hooks ( -- )
     "Stripping startup hooks" show
     "command-line" init-hooks get delete-at
-    "mallocs" init-hooks get delete-at
+    "libc" init-hooks get delete-at
-    strip-io? [ "io.backend" init-hooks get delete-at ] when ;
+    deploy-threads? get [
+        "threads" init-hooks get delete-at
+    ] unless
+    native-io? [
+        "io.thread" init-hooks get delete-at
+    ] unless
+    strip-io? [
+        "io.backend" init-hooks get delete-at
+    ] when ;
 
 : strip-debugger ( -- )
     strip-debugger? [
@@ -85,6 +93,7 @@ IN: tools.deploy.shaker
     { } set-retainstack
     V{ } set-namestack
     V{ } set-catchstack
+    
     "Saving final image" show
     [ save-image-and-exit ] call-clear ;
 

extra/tools/deploy/shaker/strip-debugger.factor

@@ -1,6 +1,8 @@
-USING: kernel ;
+USING: kernel threads threads.private ;
 IN: debugger
 
 : print-error die ;
 
 : error. die ;
+
+M: thread error-in-thread ( error thread -- ) die 2drop ;

extra/tools/deploy/windows/windows.factor

@@ -10,10 +10,10 @@ IN: tools.deploy.windows
     vm over copy-file ;
 
 : copy-fonts ( bundle-name -- )
-    "fonts/" resource-path swap copy-tree ;
+    "fonts/" resource-path swap copy-tree-to ;
 
 : copy-dlls ( bundle-name -- )
-    { "freetype6.dll" "zlib1.dll" "factor-nt.dll" }
+    { "freetype6.dll" "zlib1.dll" "factor.dll" }
     [ resource-path ] map
     swap copy-files-to ;
 
@@ -30,10 +30,11 @@ TUPLE: windows-deploy-implementation ;
 T{ windows-deploy-implementation } deploy-implementation set-global
 
 M: windows-deploy-implementation deploy*
-    "." resource-path cd
+    "." resource-path [
-    dup deploy-config [
+        dup deploy-config [
-        [ deploy-name get create-exe-dir ] keep
+            [ deploy-name get create-exe-dir ] keep
-        [ deploy-name get image-name ] keep
+            [ deploy-name get image-name ] keep
-        [ namespace make-deploy-image ] keep
+            [ namespace make-deploy-image ] keep
-        open-in-explorer
+            open-in-explorer
-    ] bind ;
+        ] bind
+    ] with-directory ;