1 ! Copyright (C) 2007, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays alien.libraries accessors io.backend
4 io.encodings.utf8 io.files io.streams.c init fry namespaces math
5 make assocs kernel parser parser.notes lexer strings.parser
6 vocabs sequences sequences.deep sequences.private words memory
7 kernel.private continuations io vocabs.loader system strings
8 sets vectors quotations byte-arrays sorting compiler.units
9 definitions generic generic.standard generic.single
10 tools.deploy.config combinators combinators.private classes
11 vocabs.loader.private classes.builtin slots.private grouping
12 command-line io.pathnames ;
13 QUALIFIED: bootstrap.stage2
14 QUALIFIED: classes.private
15 QUALIFIED: compiler.crossref
16 QUALIFIED: compiler.errors
17 QUALIFIED: continuations
18 QUALIFIED: definitions
21 QUALIFIED: source-files
22 QUALIFIED: source-files.errors
24 QUALIFIED: vocabs.loader
25 FROM: alien.libraries.private => >deployed-library-path ;
26 FROM: namespaces => set ;
27 FROM: sets => members ;
28 IN: tools.deploy.shaker
30 ! This file is some hairy shit.
32 : add-command-line-hook ( -- )
33 [ (command-line) command-line set-global ] "command-line"
34 startup-hooks get set-at ;
36 : strip-startup-hooks ( -- )
37 "Stripping startup hooks" show
44 [ startup-hooks get delete-at ] each
46 "threads" startup-hooks get delete-at
49 "io.backend" startup-hooks get delete-at
56 } [ startup-hooks get delete-at ] each
59 : strip-debugger ( -- )
60 strip-debugger? "debugger" vocab and [
61 "Stripping debugger" show
62 "vocab:tools/deploy/shaker/strip-debugger.factor"
66 : strip-ui-error-hook ( -- )
67 strip-debugger? deploy-ui? get and "ui" vocab and [
68 "Installing generic UI error hook" show
69 "vocab:tools/deploy/shaker/strip-ui-error-hook.factor"
75 "Stripping manual memory management debug code" show
76 "vocab:tools/deploy/shaker/strip-libc.factor"
80 : strip-destructors ( -- )
81 "Stripping destructor debug code" show
82 "vocab:tools/deploy/shaker/strip-destructors.factor"
86 "Stripping stack effect checking from call( and execute(" show
87 "vocab:tools/deploy/shaker/strip-call.factor" run-file ;
91 "Stripping unused Cocoa methods" show
92 "vocab:tools/deploy/shaker/strip-cocoa.factor"
96 : strip-gobject ( -- )
97 "gobject-introspection.types" vocab [
98 "Stripping GObject type info" show
99 "vocab:tools/deploy/shaker/strip-gobject.factor"
103 : strip-gtk-icon ( -- )
104 "ui.backend.gtk" vocab [
105 "Stripping GTK icon loading code" show
106 "vocab:tools/deploy/shaker/strip-gtk-icon.factor"
110 : strip-specialized-arrays ( -- )
111 strip-dictionary? "specialized-arrays" vocab and [
112 "Stripping specialized arrays" show
113 "vocab:tools/deploy/shaker/strip-specialized-arrays.factor"
117 : strip-word-names ( words -- )
118 "Stripping word names" show
119 [ f >>name f >>vocabulary drop ] each ;
121 : strip-word-defs ( words -- )
122 "Stripping symbolic word definitions" show
123 [ "no-def-strip" word-prop not ] filter
124 [ [ ] >>def drop ] each ;
126 : sift-assoc ( assoc -- assoc' ) [ nip ] assoc-filter ;
128 : strip-word-props ( stripped-props words -- )
129 "Stripping word properties" show
132 [ drop _ member? not ] assoc-filter sift-assoc
137 : stripped-word-props ( -- seq )
146 "effect-dependencies"
147 "definition-dependencies"
148 "conditional-dependencies"
157 "default-output-classes"
189 "predicate-definition"
227 deploy-c-types? get [
228 { "c-type" "struct-slots" "struct-align" } %
232 : strip-words ( props -- )
234 deploy-word-props? get [ 2dup strip-word-props ] unless
235 deploy-word-defs? get [ dup strip-word-defs ] unless
236 strip-word-names? [ dup strip-word-names strip-stack-traces ] when
239 : compiler-classes ( -- seq )
240 { "compiler" "stack-checker" }
241 [ child-vocabs [ words ] map concat [ class? ] filter ]
244 : prune-decision-tree ( tree classes -- )
245 [ tuple class>type ] 2dip '[
251 [ drop _ key? not ] assoc-filter
259 : strip-compiler-classes ( -- )
261 "Stripping compiler classes" show
262 [ single-generic? ] instances
263 compiler-classes '[ "decision-tree" word-prop _ prune-decision-tree ] each
266 : recursive-subst ( seq old new -- )
271 { [ 3dup drop eq? ] [ 2nip ] }
272 ! recurse into arrays
273 { [ pick array? ] [ [ dup ] 2dip recursive-subst ] }
274 ! otherwise do nothing
279 : strip-default-method ( generic new-default -- )
281 [ "decision-tree" word-prop ]
282 [ "default-method" word-prop ] bi
286 : new-default-method ( -- gensym )
287 [ [ "No method" throw ] (( -- * )) define-temp ] with-compilation-unit ;
289 : strip-default-methods ( -- )
290 ! In a development image, each generic has its own default method.
291 ! This gives better error messages for runtime type errors, but
292 ! takes up space. For deployment we merge them all together.
294 "Stripping default methods" show
295 [ single-generic? ] instances
296 new-default-method '[ _ strip-default-method ] each
299 : strip-vocab-globals ( except names -- words )
300 [ child-vocabs [ words ] map concat ] map concat
301 swap [ first2 lookup ] map sift diff ;
303 : stripped-globals ( -- seq )
305 "inspector-hook" "inspector" lookup ,
309 continuations:error-continuation
310 continuations:error-thread
311 continuations:restarts
313 source-files:source-files
322 "io-thread" "io.thread" lookup ,
324 "disposables" "destructors" lookup ,
326 "functor-words" "functors.backend" lookup ,
329 "initial-thread" "threads" lookup ,
332 strip-io? [ io-backend , ] when
342 } strip-vocab-globals %
345 "libraries" "alien" lookup ,
347 { { "yield-hook" "compiler.utilities" } }
348 { "cpu" "compiler" } strip-vocab-globals %
353 classes.private:next-method-quot-cache
354 classes.private:class-and-cache
355 classes.private:class-not-cache
356 classes.private:class-or-cache
357 classes.private:class<=-cache
358 classes.private:classes-intersect-cache
359 classes.private:implementors-map
360 classes.private:update-map
362 compiler.crossref:compiled-crossref
363 compiler.crossref:generic-call-site-crossref
365 compiler.errors:compiler-errors
371 source-files.errors:error-types
372 source-files.errors:error-observers
374 vocabs:load-vocab-hook
375 vocabs:vocab-observers
376 vocabs.loader:add-vocab-root-hook
381 { } { "layouts" } strip-vocab-globals %
383 { } { "math.partial-dispatch" } strip-vocab-globals %
385 { } { "math.vectors.simd" } strip-vocab-globals %
387 { } { "peg" } strip-vocab-globals %
391 { } { "prettyprint.config" } strip-vocab-globals %
396 compiler.errors:compiler-errors
397 continuations:thread-error-hook
401 "windows-messages" "windows.messages" lookup [ , ] when*
404 : strip-globals ( stripped-globals -- )
406 "Stripping globals" show
408 '[ drop _ member? not ] assoc-filter
409 [ drop string? not ] assoc-filter ! strip CLI args
411 21 set-special-object
415 ! On all platforms, if deploy-io is 1, we strip out C streams.
416 ! On Unix, if deploy-io is 3, we strip out C streams as well.
417 ! On Windows, even if deploy-io is 3, C streams are still used
418 ! for the console, so don't strip it there.
420 deploy-io get 3 = os windows? not and
422 "Stripping C I/O" show
423 "vocab:tools/deploy/shaker/strip-c-io.factor" run-file
426 : compress ( pred post-process string -- )
427 "Compressing " prepend show
428 [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
431 : compress-object? ( obj -- ? )
433 { [ dup array? ] [ empty? ] }
434 { [ dup byte-array? ] [ drop t ] }
435 { [ dup string? ] [ drop t ] }
436 { [ dup wrapper? ] [ drop t ] }
440 : compress-objects ( -- )
441 [ compress-object? ] [ ] "objects" compress ;
443 : remain-compiled ( old new -- old new )
444 ! Quotations which were formerly compiled must remain
447 2dup [ quot-compiled? ] [ quot-compiled? not ] bi* and
448 [ nip jit-compile ] [ 2drop ] if
451 : compress-quotations ( -- )
452 [ quotation? ] [ remain-compiled ] "quotations" compress
453 [ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ;
457 : [:c] ( -- word ) ":c" "debugger" lookup ;
459 : [print-error] ( -- word ) "print-error" "debugger" lookup ;
461 : deploy-startup-quot ( word -- )
464 startup-hooks get values concat %
465 strip-debugger? [ , ] [
466 ! Don't reference 'try' directly since we don't want
467 ! to pull in the debugger and prettyprinter into every
472 [ _ execute( obj -- ) ] [
473 _ execute( obj -- ) nl
478 strip-io? [ [ flush ] % ] unless
483 : startup-stripper ( -- )
485 f output-stream set-global
486 [ V{ "resource:" } clone vocab-roots set-global ]
487 "vocabs.loader" startup-hooks get-global set-at ;
489 : next-method* ( method -- quot )
490 [ "method-class" word-prop ]
491 [ "method-generic" word-prop ] bi
494 : calls-next-method? ( method -- ? )
495 def>> flatten \ (call-next-method) swap member-eq? ;
497 : compute-next-methods ( -- )
498 [ standard-generic? ] instances [
499 "methods" word-prop values [ calls-next-method? ] filter
500 [ dup next-method* "next-method" set-word-prop ] each
502 "vocab:tools/deploy/shaker/next-methods.factor" run-file ;
504 : (clear-megamorphic-cache) ( i array -- )
505 ! Can't do any dispatch while clearing caches since that
506 ! might leave them in an inconsistent state.
508 2dup [ f ] 2dip set-array-nth
509 [ 1 + ] dip (clear-megamorphic-cache)
512 : clear-megamorphic-cache ( array -- )
513 [ 0 ] dip (clear-megamorphic-cache) ;
515 : find-megamorphic-caches ( -- seq )
516 "Finding megamorphic caches" show
517 [ standard-generic? ] instances [ def>> third ] map ;
519 : clear-megamorphic-caches ( cache -- )
520 "Clearing megamorphic caches" show
521 [ clear-megamorphic-cache ] each ;
523 : write-vocab-manifest ( vocab-manifest-out -- )
524 "Writing vocabulary manifest to " write dup print flush
525 vocabs "VOCABS:" prefix
526 deploy-libraries get [ libraries get at path>> ] map members "LIBRARIES:" prefix append
527 swap utf8 set-file-lines ;
529 : prepare-deploy-libraries ( -- )
530 "Preparing deployed libraries" show
531 deploy-libraries get [
533 [ path>> >deployed-library-path ] [ abi>> ] bi <library>
538 "deploy-libraries" "alien.libraries" lookup forget
539 "deploy-library" "alien.libraries" lookup forget
540 ">deployed-library-path" "alien.libraries.private" lookup forget
541 ] with-compilation-unit ;
543 : strip ( vocab-manifest-out -- )
544 [ write-vocab-manifest ] when*
546 prepare-deploy-libraries
555 strip-specialized-arrays
558 add-command-line-hook
560 strip-default-methods
561 strip-compiler-classes
562 f 5 set-special-object ! we can't use the Factor debugger or Factor I/O anymore
563 deploy-vocab get vocab-main deploy-startup-quot
564 find-megamorphic-caches
566 stripped-globals strip-globals
570 clear-megamorphic-caches ;
572 : die-with ( error original-error -- * )
573 #! We don't want DCE to drop the error before the die call!
574 [ die 1 exit ] (( a -- * )) call-effect-unsafe ;
576 : die-with2 ( error original-error -- * )
577 #! We don't want DCE to drop the error before the die call!
578 [ die 1 exit ] (( a b -- * )) call-effect-unsafe ;
580 : deploy-error-handler ( quot -- )
583 [ original-error get die-with2 ]
584 ! Don't reference these words literally, if we're stripping the
585 ! debugger out we don't want to load the prettyprinter at all
586 [ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if
590 : (deploy) ( final-image vocab-manifest-out vocab config -- )
591 #! Does the actual work of a deployment in the slave
597 "tools.errors" require
600 "ui.debugger" require
603 [ deploy-vocab set ] [ require ] [
605 "Vocabulary has no MAIN: word." print flush 1 exit
609 "Saving final image" show
611 ] deploy-error-handler
616 "vocab-manifest-out" get
618 "Deploying " write dup write "..." print
619 "deploy-config" get parse-file first