1 ! Copyright (C) 2007, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors qualified io.backend io.streams.c init fry
4 namespaces make assocs kernel parser lexer strings.parser
5 tools.deploy.config vocabs sequences words words.private memory
6 kernel.private continuations io prettyprint vocabs.loader
7 debugger system strings sets vectors quotations byte-arrays
8 sorting compiler.units definitions ;
9 QUALIFIED: bootstrap.stage2
11 QUALIFIED: command-line
12 QUALIFIED: compiler.errors.private
13 QUALIFIED: continuations
14 QUALIFIED: definitions
18 QUALIFIED: prettyprint.config
19 QUALIFIED: source-files
21 IN: tools.deploy.shaker
23 ! This file is some hairy shit.
25 : strip-init-hooks ( -- )
26 "Stripping startup hooks" show
27 "cpu.x86" init-hooks get delete-at
28 "command-line" init-hooks get delete-at
29 "libc" init-hooks get delete-at
30 "system" init-hooks get delete-at
32 "threads" init-hooks get delete-at
35 "io.thread" init-hooks get delete-at
38 "io.files" init-hooks get delete-at
39 "io.backend" init-hooks get delete-at
42 "compiler.units" init-hooks get delete-at
43 "tools.vocabs" init-hooks get delete-at
46 : strip-debugger ( -- )
48 "Stripping debugger" show
49 "resource:basis/tools/deploy/shaker/strip-debugger.factor"
55 "Stripping manual memory management debug code" show
56 "resource:basis/tools/deploy/shaker/strip-libc.factor"
62 "Stripping unused Cocoa methods" show
63 "resource:basis/tools/deploy/shaker/strip-cocoa.factor"
67 : strip-word-names ( words -- )
68 "Stripping word names" show
69 [ f >>name f >>vocabulary drop ] each ;
71 : strip-word-defs ( words -- )
72 "Stripping symbolic word definitions" show
73 [ "no-def-strip" word-prop not ] filter
74 [ [ ] >>def drop ] each ;
76 : sift-assoc ( assoc -- assoc' ) [ nip ] assoc-filter ;
78 : strip-word-props ( stripped-props words -- )
79 "Stripping word properties" show
83 [ drop _ member? not ] assoc-filter sift-assoc
88 "Remaining word properties:\n" show
89 [ props>> keys ] gather unparse show
92 [ [ _ [ ] cache ] map ] change-props drop
96 : stripped-word-props ( -- seq )
98 strip-dictionary? deploy-compiler? get and [
113 "compiled-generic-uses"
120 "default-output-classes"
151 "predicate-definition"
168 "tuple-dispatch-generic"
192 : strip-words ( props -- )
194 deploy-word-props? get [ 2dup strip-word-props ] unless
195 deploy-word-defs? get [ dup strip-word-defs ] unless
196 strip-word-names? [ dup strip-word-names ] when
199 : strip-vocab-globals ( except names -- words )
200 [ child-vocabs [ words ] map concat ] map concat swap diff ;
202 : stripped-globals ( -- seq )
204 "callbacks" "alien.compiler" lookup ,
206 "inspector-hook" "inspector" lookup ,
209 bootstrap.stage2:bootstrap-time
211 continuations:error-continuation
212 continuations:error-thread
213 continuations:restarts
216 source-files:source-files
222 "io-thread" "io.thread" lookup ,
224 "mallocs" "libc.private" lookup ,
227 "initial-thread" "threads" lookup ,
230 strip-io? [ io-backend , ] when
237 } strip-vocab-globals %
240 "libraries" "alien" lookup ,
242 { } { "cpu" } strip-vocab-globals %
247 classes:class-and-cache
248 classes:class-not-cache
249 classes:class-or-cache
250 classes:class<=-cache
251 classes:classes-intersect-cache
252 classes:implementors-map
254 command-line:main-vocab-hook
256 compiled-generic-crossref
268 listener:listener-hook
272 vocabs:load-vocab-hook
277 { } { "math.partial-dispatch" } strip-vocab-globals %
279 "peg-cache" "peg" lookup ,
284 prettyprint.config:margin
285 prettyprint.config:string-limit?
286 prettyprint.config:boa-tuples?
287 prettyprint.config:tab-size
293 compiler.errors.private:compiler-errors
294 continuations:thread-error-hook
298 deploy-c-types? get [
299 "c-types" "alien.c-types" lookup ,
303 "ui-error-hook" "ui.gadgets.worlds" lookup ,
306 "<value>" "stack-checker.state" lookup [ , ] when*
308 "windows-messages" "windows.messages" lookup [ , ] when*
312 : strip-globals ( stripped-globals -- )
314 "Stripping globals" show
316 '[ drop _ member? not ] assoc-filter
317 [ drop string? not ] assoc-filter ! strip CLI args
319 dup keys unparse show
327 "io.streams.c" forget-vocab
328 ] with-compilation-unit
331 : compress ( pred string -- )
332 "Compressing " prepend show
334 dup H{ } clone [ [ ] cache ] curry map
337 : compress-byte-arrays ( -- )
338 [ byte-array? ] "byte arrays" compress ;
340 : compress-quotations ( -- )
341 [ quotation? ] "quotations" compress ;
343 : compress-strings ( -- )
344 [ string? ] "strings" compress ;
346 : finish-deploy ( final-image -- )
348 >r { } set-datastack r>
352 "Saving final image" show
353 [ save-image-and-exit ] call-clear ;
357 : set-boot-quot* ( word -- )
360 init-hooks get values concat %
362 strip-io? [ \ flush , ] unless
363 ] [ ] make "Boot quotation: " show dup unparse show
366 : init-stripper ( -- )
368 f output-stream set-global ;
377 f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
378 deploy-vocab get vocab-main set-boot-quot*
379 stripped-word-props >r
380 stripped-globals strip-globals
385 H{ } clone classes:next-method-quot-cache set-global ;
387 : (deploy) ( final-image vocab config -- )
388 #! Does the actual work of a deployment in the slave
393 deploy-vocab get require
397 print-error flush 1 exit
404 "Deploying " write dup write "..." print
405 dup deploy-config dup .