1 ! Copyright (C) 2007, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays accessors io.backend io.streams.c init fry
4 namespaces math make assocs kernel parser parser.notes lexer
5 strings.parser vocabs sequences sequences.deep sequences.private
6 words memory kernel.private continuations io vocabs.loader
7 system strings sets vectors quotations byte-arrays sorting
8 compiler.units definitions generic generic.standard
9 generic.single tools.deploy.config combinators classes
10 classes.builtin slots.private grouping command-line ;
11 QUALIFIED: bootstrap.stage2
12 QUALIFIED: compiler.errors
13 QUALIFIED: continuations
14 QUALIFIED: definitions
17 QUALIFIED: source-files
18 QUALIFIED: source-files.errors
20 IN: tools.deploy.shaker
22 ! This file is some hairy shit.
24 : add-command-line-hook ( -- )
25 [ (command-line) command-line set-global ] "command-line"
26 init-hooks get set-at ;
28 : strip-init-hooks ( -- )
29 "Stripping startup hooks" show
37 [ init-hooks get delete-at ] each
39 "threads" init-hooks get delete-at
42 "io.thread" init-hooks get delete-at
45 "io.files" init-hooks get delete-at
46 "io.backend" init-hooks get delete-at
47 "io.thread" init-hooks get delete-at
55 } [ init-hooks get delete-at ] each
58 : strip-debugger ( -- )
59 strip-debugger? "debugger" vocab and [
60 "Stripping debugger" show
61 "vocab:tools/deploy/shaker/strip-debugger.factor"
67 "Stripping manual memory management debug code" show
68 "vocab:tools/deploy/shaker/strip-libc.factor"
72 : strip-destructors ( -- )
73 "Stripping destructor debug code" show
74 "vocab:tools/deploy/shaker/strip-destructors.factor"
78 "Stripping stack effect checking from call( and execute(" show
79 "vocab:tools/deploy/shaker/strip-call.factor" run-file ;
83 "Stripping unused Cocoa methods" show
84 "vocab:tools/deploy/shaker/strip-cocoa.factor"
88 : strip-word-names ( words -- )
89 "Stripping word names" show
90 [ f >>name f >>vocabulary drop ] each ;
92 : strip-word-defs ( words -- )
93 "Stripping symbolic word definitions" show
94 [ "no-def-strip" word-prop not ] filter
95 [ [ ] >>def drop ] each ;
97 : sift-assoc ( assoc -- assoc' ) [ nip ] assoc-filter ;
99 : strip-word-props ( stripped-props words -- )
100 "Stripping word properties" show
104 [ drop _ member? not ] assoc-filter sift-assoc
110 [ [ _ [ ] cache ] map ] change-props drop
114 : stripped-word-props ( -- seq )
122 "compiled-generic-uses"
131 "default-output-classes"
164 "predicate-definition"
202 deploy-c-types? get [
203 { "c-type" "struct-slots" "struct-align" } %
207 : strip-words ( props -- )
209 deploy-word-props? get [ 2dup strip-word-props ] unless
210 deploy-word-defs? get [ dup strip-word-defs ] unless
211 strip-word-names? [ dup strip-word-names strip-stack-traces ] when
214 : compiler-classes ( -- seq )
215 { "compiler" "stack-checker" }
216 [ child-vocabs [ words ] map concat [ class? ] filter ]
219 : prune-decision-tree ( tree classes -- )
220 [ tuple class>type ] 2dip '[
226 [ drop _ key? not ] assoc-filter
234 : strip-compiler-classes ( -- )
236 "Stripping compiler classes" show
237 [ single-generic? ] instances
238 compiler-classes '[ "decision-tree" word-prop _ prune-decision-tree ] each
241 : recursive-subst ( seq old new -- )
246 { [ 3dup drop eq? ] [ 2nip ] }
247 ! recurse into arrays
248 { [ pick array? ] [ [ dup ] 2dip recursive-subst ] }
249 ! otherwise do nothing
254 : strip-default-method ( generic new-default -- )
256 [ "decision-tree" word-prop ]
257 [ "default-method" word-prop ] bi
261 : new-default-method ( -- gensym )
262 [ [ "No method" throw ] (( -- * )) define-temp ] with-compilation-unit ;
264 : strip-default-methods ( -- )
265 ! In a development image, each generic has its own default method.
266 ! This gives better error messages for runtime type errors, but
267 ! takes up space. For deployment we merge them all together.
269 "Stripping default methods" show
270 [ single-generic? ] instances
271 new-default-method '[ _ strip-default-method ] each
274 : strip-vocab-globals ( except names -- words )
275 [ child-vocabs [ words ] map concat ] map concat
276 swap [ first2 lookup ] map sift diff ;
278 : stripped-globals ( -- seq )
280 "inspector-hook" "inspector" lookup ,
284 continuations:error-continuation
285 continuations:error-thread
286 continuations:restarts
288 source-files:source-files
294 "io-thread" "io.thread" lookup ,
296 "disposables" "destructors" lookup ,
298 "functor-words" "functors.backend" lookup ,
301 "initial-thread" "threads" lookup ,
304 strip-io? [ io-backend , ] when
314 } strip-vocab-globals %
317 "libraries" "alien" lookup ,
319 { { "yield-hook" "compiler.utilities" } }
320 { "cpu" "compiler" } strip-vocab-globals %
325 next-method-quot-cache
330 classes-intersect-cache
335 compiled-generic-crossref
337 compiler.errors:compiler-errors
341 source-files.errors:error-types
342 source-files.errors:error-observers
344 vocabs:load-vocab-hook
345 vocabs:vocab-observers
350 { } { "layouts" } strip-vocab-globals %
352 { } { "math.partial-dispatch" } strip-vocab-globals %
354 { } { "math.vectors.simd" } strip-vocab-globals %
356 { } { "peg" } strip-vocab-globals %
360 { } { "prettyprint.config" } strip-vocab-globals %
365 compiler.errors:compiler-errors
366 continuations:thread-error-hook
370 "ui-error-hook" "ui.gadgets.worlds" lookup ,
374 deploy-c-types? get [
375 "c-types" "alien.c-types" lookup ,
378 "windows-messages" "windows.messages" lookup [ , ] when*
381 : strip-globals ( stripped-globals -- )
383 "Stripping globals" show
385 '[ drop _ member? not ] assoc-filter
386 [ drop string? not ] assoc-filter ! strip CLI args
393 deploy-io get 3 = os windows? not and
397 "io.streams.c" forget-vocab
398 "io-thread-running?" "io.thread" lookup [
401 ] with-compilation-unit
404 : compress ( pred post-process string -- )
405 "Compressing " prepend show
406 [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
409 : compress-object? ( obj -- ? )
411 { [ dup array? ] [ empty? ] }
412 { [ dup byte-array? ] [ drop t ] }
413 { [ dup string? ] [ drop t ] }
414 { [ dup wrapper? ] [ drop t ] }
418 : compress-objects ( -- )
419 [ compress-object? ] [ ] "objects" compress ;
421 : remain-compiled ( old new -- old new )
422 ! Quotations which were formerly compiled must remain
425 2dup [ quot-compiled? ] [ quot-compiled? not ] bi* and
426 [ nip jit-compile ] [ 2drop ] if
429 : compress-quotations ( -- )
430 [ quotation? ] [ remain-compiled ] "quotations" compress
431 [ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ;
435 : [:c] ( -- word ) ":c" "debugger" lookup ;
437 : [print-error] ( -- word ) "print-error" "debugger" lookup ;
439 : deploy-boot-quot ( word -- )
442 init-hooks get values concat %
443 strip-debugger? [ , ] [
444 ! Don't reference 'try' directly since we don't want
445 ! to pull in the debugger and prettyprinter into every
450 [ _ execute( obj -- ) ] [
451 _ execute( obj -- ) nl
456 strip-io? [ [ flush ] % ] unless
461 : init-stripper ( -- )
463 f output-stream set-global ;
465 : next-method* ( method -- quot )
466 [ "method-class" word-prop ]
467 [ "method-generic" word-prop ] bi
470 : calls-next-method? ( method -- ? )
471 def>> flatten \ (call-next-method) swap memq? ;
473 : compute-next-methods ( -- )
474 [ standard-generic? ] instances [
475 "methods" word-prop values [ calls-next-method? ] filter
476 [ dup next-method* "next-method" set-word-prop ] each
478 "vocab:tools/deploy/shaker/next-methods.factor" run-file ;
480 : (clear-megamorphic-cache) ( i array -- )
481 ! Can't do any dispatch while clearing caches since that
482 ! might leave them in an inconsistent state.
484 2dup [ f ] 2dip set-array-nth
485 [ 1 + ] dip (clear-megamorphic-cache)
488 : clear-megamorphic-cache ( array -- )
489 [ 0 ] dip (clear-megamorphic-cache) ;
491 : find-megamorphic-caches ( -- seq )
492 "Finding megamorphic caches" show
493 [ standard-generic? ] instances [ def>> third ] map ;
495 : clear-megamorphic-caches ( cache -- )
496 "Clearing megamorphic caches" show
497 [ clear-megamorphic-cache ] each ;
508 add-command-line-hook
510 strip-default-methods
511 strip-compiler-classes
512 f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
513 deploy-vocab get vocab-main deploy-boot-quot
514 find-megamorphic-caches
516 stripped-globals strip-globals
520 clear-megamorphic-caches ;
522 : deploy-error-handler ( quot -- )
525 [ error-continuation get call>> callstack>array die 1 exit ]
526 ! Don't reference these words literally, if we're stripping the
527 ! debugger out we don't want to load the prettyprinter at all
528 [ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if
532 : (deploy) ( final-image vocab config -- )
533 #! Does the actual work of a deployment in the slave
541 "ui.debugger" require
545 deploy-vocab get require
546 deploy-vocab get vocab-main [
547 "Vocabulary has no MAIN: word." print flush 1 exit
550 "Saving final image" show
552 ] deploy-error-handler
558 "Deploying " write dup write "..." print
559 "deploy-config" get parse-file first