1 ! Copyright (C) 2007, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors io.backend io.streams.c init fry
4 namespaces make assocs kernel parser lexer strings.parser vocabs
5 sequences words words.private memory kernel.private
6 continuations io vocabs.loader system strings sets
7 vectors quotations byte-arrays sorting compiler.units
8 definitions generic generic.standard tools.deploy.config ;
9 QUALIFIED: bootstrap.stage2
11 QUALIFIED: command-line
12 QUALIFIED: compiler.errors
13 QUALIFIED: continuations
14 QUALIFIED: definitions
17 QUALIFIED: source-files
19 IN: tools.deploy.shaker
21 ! This file is some hairy shit.
23 : strip-init-hooks ( -- )
24 "Stripping startup hooks" show
25 { "cpu.x86" "command-line" "libc" "system" "environment" }
26 [ init-hooks get delete-at ] each
28 "threads" init-hooks get delete-at
31 "io.thread" init-hooks get delete-at
34 "io.files" init-hooks get delete-at
35 "io.backend" init-hooks get delete-at
38 "compiler.units" init-hooks get delete-at
39 "tools.vocabs" init-hooks get delete-at
42 : strip-debugger ( -- )
43 strip-debugger? "debugger" vocab and [
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
85 [ [ _ [ ] cache ] map ] change-props drop
89 : stripped-word-props ( -- seq )
99 "compiled-generic-uses"
106 "default-output-classes"
140 "predicate-definition"
157 "tuple-dispatch-generic"
181 : strip-words ( props -- )
183 deploy-word-props? get [ 2dup strip-word-props ] unless
184 deploy-word-defs? get [ dup strip-word-defs ] unless
185 strip-word-names? [ dup strip-word-names ] when
188 : strip-default-methods ( -- )
190 "Stripping default methods" show
192 [ generic? ] instances
193 [ "No method" throw ] define-temp
194 dup t "default" set-word-prop
196 [ _ "default-method" set-word-prop ] [ make-generic ] bi
198 ] with-compilation-unit
201 : strip-vocab-globals ( except names -- words )
202 [ child-vocabs [ words ] map concat ] map concat swap diff ;
204 : stripped-globals ( -- seq )
206 "inspector-hook" "inspector" lookup ,
210 continuations:error-continuation
211 continuations:error-thread
212 continuations:restarts
214 source-files:source-files
220 "io-thread" "io.thread" lookup ,
222 "mallocs" "libc.private" lookup ,
225 "initial-thread" "threads" lookup ,
228 strip-io? [ io-backend , ] when
239 } strip-vocab-globals %
242 "libraries" "alien" lookup ,
244 { } { "cpu" } strip-vocab-globals %
249 classes:next-method-quot-cache
250 classes:class-and-cache
251 classes:class-not-cache
252 classes:class-or-cache
253 classes:class<=-cache
254 classes:classes-intersect-cache
255 classes:implementors-map
257 command-line:main-vocab-hook
259 compiled-generic-crossref
276 vocabs:load-vocab-hook
281 { } { "math.partial-dispatch" } strip-vocab-globals %
283 { } { "peg" } strip-vocab-globals %
287 { } { "prettyprint.config" } strip-vocab-globals %
292 compiler.errors:compiler-errors
293 continuations:thread-error-hook
297 deploy-c-types? get [
298 "c-types" "alien.c-types" lookup ,
302 "ui-error-hook" "ui.gadgets.worlds" lookup ,
305 "windows-messages" "windows.messages" lookup [ , ] when*
308 : strip-globals ( stripped-globals -- )
310 "Stripping globals" show
312 '[ drop _ member? not ] assoc-filter
313 [ drop string? not ] assoc-filter ! strip CLI args
319 deploy-io get 2 = os windows? or [
322 "io.streams.c" forget-vocab
323 ] with-compilation-unit
326 : compress ( pred post-process string -- )
327 "Compressing " prepend show
328 [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
331 : compress-byte-arrays ( -- )
332 [ byte-array? ] [ ] "byte arrays" compress ;
334 : remain-compiled ( old new -- old new )
335 #! Quotations which were formerly compiled must remain
338 2dup [ compiled>> ] [ compiled>> not ] bi* and
339 [ nip jit-compile ] [ 2drop ] if
342 : compress-quotations ( -- )
343 [ quotation? ] [ remain-compiled ] "quotations" compress ;
345 : compress-strings ( -- )
346 [ string? ] [ ] "strings" compress ;
348 : compress-wrappers ( -- )
349 [ wrapper? ] [ ] "wrappers" compress ;
351 : finish-deploy ( final-image -- )
353 [ { } set-datastack ] dip
357 "Saving final image" show
358 [ save-image-and-exit ] call-clear ;
362 : set-boot-quot* ( word -- )
365 init-hooks get values concat %
367 strip-io? [ \ flush , ] unless
372 : init-stripper ( -- )
374 f output-stream set-global ;
376 : compute-next-methods ( -- )
377 [ standard-generic? ] instances [
378 "methods" word-prop [
380 dup next-method-quot "next-method-quot" set-word-prop
383 "resource:basis/tools/deploy/shaker/next-methods.factor" run-file ;
387 strip-default-methods
394 f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
395 deploy-vocab get vocab-main set-boot-quot*
397 stripped-globals strip-globals
404 : (deploy) ( final-image vocab config -- )
405 #! Does the actual work of a deployment in the slave
410 deploy-vocab get require
413 ] [ error-continuation get call>> callstack>array die 1 exit ] recover
419 "Deploying " write dup write "..." print
420 "deploy-config" get parse-file first