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
19 QUALIFIED: libc.private
20 QUALIFIED: libc.private
22 QUALIFIED: prettyprint.config
23 QUALIFIED: source-files
26 IN: tools.deploy.shaker
28 ! This file is some hairy shit.
30 : strip-init-hooks ( -- )
31 "Stripping startup hooks" show
32 "cpu.x86" init-hooks get delete-at
33 "command-line" init-hooks get delete-at
34 "libc" init-hooks get delete-at
36 "threads" init-hooks get delete-at
39 "io.thread" init-hooks get delete-at
42 "io.backend" init-hooks get delete-at
45 : strip-debugger ( -- )
47 "Stripping debugger" show
48 "resource:basis/tools/deploy/shaker/strip-debugger.factor"
54 "Stripping manual memory management debug code" show
55 "resource:basis/tools/deploy/shaker/strip-libc.factor"
61 "Stripping unused Cocoa methods" show
62 "resource:basis/tools/deploy/shaker/strip-cocoa.factor"
66 : strip-word-names ( words -- )
67 "Stripping word names" show
68 [ f >>name f >>vocabulary drop ] each ;
70 : strip-word-defs ( words -- )
71 "Stripping symbolic word definitions" show
72 [ "no-def-strip" word-prop not ] filter
73 [ [ ] >>def drop ] each ;
75 : sift-assoc ( assoc -- assoc' ) [ nip ] assoc-filter ;
77 : strip-word-props ( stripped-props words -- )
78 "Stripping word properties" show
82 '[ drop , member? not ] assoc-filter sift-assoc
83 dup assoc-empty? [ drop f ] [ >alist >vector ] if
87 : stripped-word-props ( -- seq )
98 "default-output-classes"
119 "predicate-definition"
121 "tuple-dispatch-generic"
152 : strip-words ( props -- )
154 deploy-word-props? get [ 2dup strip-word-props ] unless
155 deploy-word-defs? get [ dup strip-word-defs ] unless
156 strip-word-names? [ dup strip-word-names ] when
159 : strip-recompile-hook ( -- )
160 [ [ f ] { } map>assoc ]
161 compiler.units:recompile-hook
164 : strip-vocab-globals ( except names -- words )
165 [ child-vocabs [ words ] map concat ] map concat swap diff ;
167 : stripped-globals ( -- seq )
169 "callbacks" "alien.compiler" lookup ,
171 "inspector-hook" "inspector" lookup ,
174 bootstrap.stage2:bootstrap-time
176 continuations:error-continuation
177 continuations:error-thread
178 continuations:restarts
183 source-files:source-files
190 threads:initial-thread ,
193 strip-io? [ io.backend:io-backend , ] when
199 } strip-vocab-globals %
202 { } { "cpu" } strip-vocab-globals %
207 classes:class-and-cache
208 classes:class-not-cache
209 classes:class-or-cache
210 classes:class<=-cache
211 classes:classes-intersect-cache
212 classes:implementors-map
214 command-line:main-vocab-hook
216 compiler.units:recompile-hook
217 compiler.units:update-tuples-hook
226 listener:listener-hook
230 vocabs:load-vocab-hook
234 { } { "optimizer.math.partial" } strip-vocab-globals %
239 prettyprint.config:margin
240 prettyprint.config:string-limit
241 prettyprint.config:tab-size
247 compiler.errors.private:compiler-errors
248 continuations:thread-error-hook
252 deploy-c-types? get [
253 "c-types" "alien.c-types" lookup ,
257 "ui-error-hook" "ui.gadgets.worlds" lookup ,
260 "<computer>" "inference.dataflow" lookup [ , ] when*
262 "windows-messages" "windows.messages" lookup [ , ] when*
266 : strip-globals ( stripped-globals -- )
268 "Stripping globals" show
270 '[ drop , member? not ] assoc-filter
271 [ drop string? not ] assoc-filter ! strip CLI args
273 dup keys unparse show
277 : compress ( pred string -- )
278 "Compressing " prepend show
280 dup H{ } clone [ [ ] cache ] curry map
283 : compress-byte-arrays ( -- )
284 [ byte-array? ] "byte arrays" compress ;
286 : compress-quotations ( -- )
287 [ quotation? ] "quotations" compress ;
289 : compress-strings ( -- )
290 [ string? ] "strings" compress ;
292 : finish-deploy ( final-image -- )
294 >r { } set-datastack r>
298 "Saving final image" show
299 [ save-image-and-exit ] call-clear ;
303 : set-boot-quot* ( word -- )
306 init-hooks get values concat %
308 strip-io? [ \ flush , ] unless
309 ] [ ] make "Boot quotation: " write dup . flush
318 deploy-vocab get vocab-main set-boot-quot*
319 stripped-word-props >r
320 stripped-globals strip-globals
326 : (deploy) ( final-image vocab config -- )
327 #! Does the actual work of a deployment in the slave
332 deploy-vocab get require
336 print-error flush 1 exit
343 "Deploying " write dup write "..." print
344 dup deploy-config dup .