1 ! Copyright (C) 2007, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors qualified io.streams.c init fry namespaces
4 assocs kernel parser lexer strings.parser tools.deploy.config
5 vocabs sequences words words.private memory kernel.private
6 continuations io prettyprint vocabs.loader debugger system
7 strings sets vectors quotations byte-arrays ;
8 QUALIFIED: bootstrap.stage2
10 QUALIFIED: command-line
11 QUALIFIED: compiler.errors.private
12 QUALIFIED: compiler.units
13 QUALIFIED: continuations
14 QUALIFIED: definitions
20 QUALIFIED: prettyprint.config
21 QUALIFIED: source-files
23 IN: tools.deploy.shaker
25 ! This file is some hairy shit.
27 : strip-init-hooks ( -- )
28 "Stripping startup hooks" show
29 "cpu.x86" init-hooks get delete-at
30 "command-line" init-hooks get delete-at
31 "libc" init-hooks get delete-at
33 "threads" init-hooks get delete-at
36 "io.thread" init-hooks get delete-at
39 "io.backend" init-hooks get delete-at
42 : strip-debugger ( -- )
44 "Stripping debugger" show
45 "resource:basis/tools/deploy/shaker/strip-debugger.factor"
51 "Stripping manual memory management debug code" show
52 "resource:basis/tools/deploy/shaker/strip-libc.factor"
58 "Stripping unused Cocoa methods" show
59 "resource:basis/tools/deploy/shaker/strip-cocoa.factor"
63 : strip-word-names ( words -- )
64 "Stripping word names" show
65 [ f >>name f >>vocabulary drop ] each ;
67 : strip-word-defs ( words -- )
68 "Stripping symbolic word definitions" show
69 [ "no-def-strip" word-prop not ] filter
70 [ [ ] >>def drop ] each ;
72 : sift-assoc ( assoc -- assoc' ) [ nip ] assoc-filter ;
74 : strip-word-props ( stripped-props words -- )
75 "Stripping word properties" show
79 '[ drop , member? not ] assoc-filter sift-assoc
80 dup assoc-empty? [ drop f ] [ >alist >vector ] if
84 : stripped-word-props ( -- seq )
92 "compiled-generic-uses"
98 "default-output-classes"
127 "predicate-definition"
141 "tuple-dispatch-generic"
165 : strip-words ( props -- )
167 deploy-word-props? get [ 2dup strip-word-props ] unless
168 deploy-word-defs? get [ dup strip-word-defs ] unless
169 strip-word-names? [ dup strip-word-names ] when
172 : strip-recompile-hook ( -- )
173 [ [ f ] { } map>assoc ]
174 compiler.units:recompile-hook
177 : strip-vocab-globals ( except names -- words )
178 [ child-vocabs [ words ] map concat ] map concat swap diff ;
180 : stripped-globals ( -- seq )
182 "callbacks" "alien.compiler" lookup ,
184 "inspector-hook" "inspector" lookup ,
187 bootstrap.stage2:bootstrap-time
189 continuations:error-continuation
190 continuations:error-thread
191 continuations:restarts
195 source-files:source-files
201 "mallocs" "libc.private" lookup ,
204 "initial-thread" "threads" lookup ,
207 strip-io? [ io.backend:io-backend , ] when
213 } strip-vocab-globals %
216 { } { "cpu" } strip-vocab-globals %
221 classes:class-and-cache
222 classes:class-not-cache
223 classes:class-or-cache
224 classes:class<=-cache
225 classes:classes-intersect-cache
226 classes:implementors-map
228 command-line:main-vocab-hook
230 compiled-generic-crossref
231 compiler.units:recompile-hook
232 compiler.units:update-tuples-hook
241 listener:listener-hook
245 vocabs:load-vocab-hook
249 { } { "math.partial-dispatch" } strip-vocab-globals %
254 prettyprint.config:margin
255 prettyprint.config:string-limit?
256 prettyprint.config:boa-tuples?
257 prettyprint.config:tab-size
263 compiler.errors.private:compiler-errors
264 continuations:thread-error-hook
268 deploy-c-types? get [
269 "c-types" "alien.c-types" lookup ,
273 "ui-error-hook" "ui.gadgets.worlds" lookup ,
276 "<computer>" "inference.dataflow" lookup [ , ] when*
278 "windows-messages" "windows.messages" lookup [ , ] when*
282 : strip-globals ( stripped-globals -- )
284 "Stripping globals" show
286 '[ drop , member? not ] assoc-filter
287 [ drop string? not ] assoc-filter ! strip CLI args
289 dup keys unparse show
293 : compress ( pred string -- )
294 "Compressing " prepend show
296 dup H{ } clone [ [ ] cache ] curry map
299 : compress-byte-arrays ( -- )
300 [ byte-array? ] "byte arrays" compress ;
302 : compress-quotations ( -- )
303 [ quotation? ] "quotations" compress ;
305 : compress-strings ( -- )
306 [ string? ] "strings" compress ;
308 : finish-deploy ( final-image -- )
310 >r { } set-datastack r>
314 "Saving final image" show
315 [ save-image-and-exit ] call-clear ;
319 : set-boot-quot* ( word -- )
322 init-hooks get values concat %
324 strip-io? [ \ flush , ] unless
325 ] [ ] make "Boot quotation: " write dup . flush
334 deploy-vocab get vocab-main set-boot-quot*
335 stripped-word-props >r
336 stripped-globals strip-globals
342 : (deploy) ( final-image vocab config -- )
343 #! Does the actual work of a deployment in the slave
348 deploy-vocab get require
352 print-error flush 1 exit
359 "Deploying " write dup write "..." print
360 dup deploy-config dup .