basis/tools/deploy/shaker/shaker.factor

   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
  19 QUALIFIED: init
  20 QUALIFIED: layouts
  21 QUALIFIED: source-files
  22 QUALIFIED: source-files.errors
  23 QUALIFIED: vocabs
  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
  29
  30 ! This file is some hairy shit.
  31
  32 : add-command-line-hook ( -- )
  33     [ (command-line) command-line set-global ] "command-line"
  34     startup-hooks get set-at ;
  35
  36 : strip-startup-hooks ( -- )
  37     "Stripping startup hooks" show
  38     {
  39         "alien.strings"
  40         "cpu.x86"
  41         "environment"
  42         "libc"
  43     }
  44     [ startup-hooks get delete-at ] each
  45     deploy-threads? get [
  46         "threads" startup-hooks get delete-at
  47     ] unless
  48     strip-io? [
  49         "io.backend" startup-hooks get delete-at
  50     ] when
  51     strip-dictionary? [
  52         {
  53             "vocabs"
  54             "vocabs.cache"
  55             "source-files.errors"
  56         } [ startup-hooks get delete-at ] each
  57     ] when ;
  58
  59 : strip-debugger ( -- )
  60     strip-debugger? "debugger" vocab and [
  61         "Stripping debugger" show
  62         "vocab:tools/deploy/shaker/strip-debugger.factor"
  63         run-file
  64     ] when ;
  65
  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"
  70         run-file
  71     ] when ;
  72
  73 : strip-libc ( -- )
  74     "libc" vocab [
  75         "Stripping manual memory management debug code" show
  76         "vocab:tools/deploy/shaker/strip-libc.factor"
  77         run-file
  78     ] when ;
  79
  80 : strip-destructors ( -- )
  81     "Stripping destructor debug code" show
  82     "vocab:tools/deploy/shaker/strip-destructors.factor"
  83     run-file ;
  84
  85 : strip-call ( -- )
  86     "Stripping stack effect checking from call( and execute(" show
  87     "vocab:tools/deploy/shaker/strip-call.factor" run-file ;
  88
  89 : strip-cocoa ( -- )
  90     "cocoa" vocab [
  91         "Stripping unused Cocoa methods" show
  92         "vocab:tools/deploy/shaker/strip-cocoa.factor"
  93         run-file
  94     ] when ;
  95
  96 : strip-gtk-icon ( -- )
  97     "ui.backend.gtk" vocab [
  98         "Stripping GTK icon loading code" show
  99         "vocab:tools/deploy/shaker/strip-gtk-icon.factor"
 100         run-file
 101     ] when ;
 102
 103 : strip-specialized-arrays ( -- )
 104     strip-dictionary? "specialized-arrays" vocab and [
 105         "Stripping specialized arrays" show
 106         "vocab:tools/deploy/shaker/strip-specialized-arrays.factor"
 107         run-file
 108     ] when ;
 109
 110 : strip-word-names ( words -- )
 111     "Stripping word names" show
 112     [ f >>name f >>vocabulary drop ] each ;
 113
 114 : strip-word-defs ( words -- )
 115     "Stripping symbolic word definitions" show
 116     [ "no-def-strip" word-prop not ] filter
 117     [ [ ] >>def drop ] each ;
 118
 119 : sift-assoc ( assoc -- assoc' ) [ nip ] assoc-filter ;
 120
 121 : strip-word-props ( stripped-props words -- )
 122     "Stripping word properties" show
 123     swap '[
 124         [
 125             [ drop _ member? not ] assoc-filter sift-assoc
 126             >alist f like
 127         ] change-props drop
 128     ] each ;
 129
 130 : stripped-word-props ( -- seq )
 131     [
 132         strip-dictionary? [
 133             {
 134                 "alias"
 135                 "boa-check"
 136                 "coercer"
 137                 "combination"
 138                 "generic-call-sites"
 139                 "effect-dependencies"
 140                 "definition-dependencies"
 141                 "conditional-dependencies"
 142                 "dependency-checks"
 143                 "constant"
 144                 "constraints"
 145                 "custom-inlining"
 146                 "decision-tree"
 147                 "declared-effect"
 148                 "default"
 149                 "default-method"
 150                 "default-output-classes"
 151                 "derived-from"
 152                 "ebnf-parser"
 153                 "engines"
 154                 "forgotten"
 155                 "identities"
 156                 "inline"
 157                 "inlined-block"
 158                 "input-classes"
 159                 "instances"
 160                 "interval"
 161                 "intrinsic"
 162                 "lambda"
 163                 "loc"
 164                 "local-reader"
 165                 "local-reader?"
 166                 "local-writer"
 167                 "local-writer?"
 168                 "local?"
 169                 "low-order"
 170                 "macro"
 171                 "members"
 172                 "memo-quot"
 173                 "methods"
 174                 "method-class"
 175                 "method-generic"
 176                 "modular-arithmetic"
 177                 "no-compile"
 178                 "owner-generic"
 179                 "outputs"
 180                 "participants"
 181                 "predicate"
 182                 "predicate-definition"
 183                 "predicating"
 184                 "reader"
 185                 "reading"
 186                 "recursive"
 187                 "register"
 188                 "register-size"
 189                 "shuffle"
 190                 "slots"
 191                 "special"
 192                 "specializer"
 193                 "struct-slots"
 194                 ! UI needs this
 195                 ! "superclass"
 196                 "transform-n"
 197                 "transform-quot"
 198                 "type"
 199                 "typed-def"
 200                 "typed-word"
 201                 "writer"
 202                 "writing"
 203             } %
 204         ] when
 205
 206         strip-prettyprint? [
 207             {
 208                 "delimiter"
 209                 "flushable"
 210                 "foldable"
 211                 "inline"
 212                 "lambda"
 213                 "macro"
 214                 "memo-quot"
 215                 "parsing"
 216                 "word-style"
 217             } %
 218         ] when
 219
 220         deploy-c-types? get [
 221             { "c-type" "struct-slots" "struct-align" } %
 222         ] unless
 223     ] { } make ;
 224
 225 : strip-words ( props -- )
 226     [ word? ] instances
 227     deploy-word-props? get [ 2dup strip-word-props ] unless
 228     deploy-word-defs? get [ dup strip-word-defs ] unless
 229     strip-word-names? [ dup strip-word-names strip-stack-traces ] when
 230     2drop ;
 231
 232 : compiler-classes ( -- seq )
 233     { "compiler" "stack-checker" }
 234     [ child-vocabs [ words ] map concat [ class? ] filter ]
 235     map concat unique ;
 236
 237 : prune-decision-tree ( tree classes -- )
 238     [ tuple class>type ] 2dip '[
 239         dup array? [
 240             [
 241                 dup array? [
 242                     [
 243                         2 group
 244                         [ drop _ key? not ] assoc-filter
 245                         concat
 246                     ] map
 247                 ] when
 248             ] map
 249         ] when
 250     ] change-nth ;
 251
 252 : strip-compiler-classes ( -- )
 253     strip-dictionary? [
 254         "Stripping compiler classes" show
 255         [ single-generic? ] instances
 256         compiler-classes '[ "decision-tree" word-prop _ prune-decision-tree ] each
 257     ] when ;
 258
 259 : recursive-subst ( seq old new -- )
 260     '[
 261         _ _
 262         {
 263             ! old becomes new
 264             { [ 3dup drop eq? ] [ 2nip ] }
 265             ! recurse into arrays
 266             { [ pick array? ] [ [ dup ] 2dip recursive-subst ] }
 267             ! otherwise do nothing
 268             [ 2drop ]
 269         } cond
 270     ] map! drop ;
 271
 272 : strip-default-method ( generic new-default -- )
 273     [
 274         [ "decision-tree" word-prop ]
 275         [ "default-method" word-prop ] bi
 276     ] dip
 277     recursive-subst ;
 278
 279 : new-default-method ( -- gensym )
 280     [ [ "No method" throw ] (( -- * )) define-temp ] with-compilation-unit ;
 281
 282 : strip-default-methods ( -- )
 283     ! In a development image, each generic has its own default method.
 284     ! This gives better error messages for runtime type errors, but
 285     ! takes up space. For deployment we merge them all together.
 286     strip-debugger? [
 287         "Stripping default methods" show
 288         [ single-generic? ] instances
 289         new-default-method '[ _ strip-default-method ] each
 290     ] when ;
 291
 292 : strip-vocab-globals ( except names -- words )
 293     [ child-vocabs [ words ] map concat ] map concat
 294     swap [ first2 lookup ] map sift diff ;
 295
 296 : stripped-globals ( -- seq )
 297     [
 298         "inspector-hook" "inspector" lookup ,
 299
 300         {
 301             continuations:error
 302             continuations:error-continuation
 303             continuations:error-thread
 304             continuations:restarts
 305             init:startup-hooks
 306             source-files:source-files
 307             input-stream
 308             output-stream
 309             error-stream
 310             vm
 311             image
 312             current-directory
 313         } %
 314
 315         "io-thread" "io.thread" lookup ,
 316
 317         "disposables" "destructors" lookup ,
 318
 319         "functor-words" "functors.backend" lookup ,
 320
 321         deploy-threads? [
 322             "initial-thread" "threads" lookup ,
 323         ] unless
 324
 325         strip-io? [ io-backend , ] when
 326
 327         { } {
 328             "timers"
 329             "tools"
 330             "io.launcher"
 331             "random"
 332             "stack-checker"
 333             "bootstrap"
 334             "listener"
 335         } strip-vocab-globals %
 336
 337         strip-dictionary? [
 338             "libraries" "alien" lookup ,
 339
 340             { { "yield-hook" "compiler.utilities" } }
 341             { "cpu" "compiler" } strip-vocab-globals %
 342
 343             {
 344                 gensym
 345                 name>char-hook
 346                 classes.private:next-method-quot-cache
 347                 classes.private:class-and-cache
 348                 classes.private:class-not-cache
 349                 classes.private:class-or-cache
 350                 classes.private:class<=-cache
 351                 classes.private:classes-intersect-cache
 352                 classes.private:implementors-map
 353                 classes.private:update-map
 354                 main-vocab-hook
 355                 compiler.crossref:compiled-crossref
 356                 compiler.crossref:generic-call-site-crossref
 357                 compiler-impl
 358                 compiler.errors:compiler-errors
 359                 lexer-factory
 360                 print-use-hook
 361                 root-cache
 362                 require-when-vocabs
 363                 require-when-table
 364                 source-files.errors:error-types
 365                 source-files.errors:error-observers
 366                 vocabs:dictionary
 367                 vocabs:load-vocab-hook
 368                 vocabs:vocab-observers
 369                 vocabs.loader:add-vocab-root-hook
 370                 word
 371                 parser-notes
 372             } %
 373
 374             { } { "layouts" } strip-vocab-globals %
 375
 376             { } { "math.partial-dispatch" } strip-vocab-globals %
 377
 378             { } { "math.vectors.simd" } strip-vocab-globals %
 379
 380             { } { "peg" } strip-vocab-globals %
 381         ] when
 382
 383         strip-prettyprint? [
 384             { } { "prettyprint.config" } strip-vocab-globals %
 385         ] when
 386
 387         strip-debugger? [
 388             {
 389                 compiler.errors:compiler-errors
 390                 continuations:thread-error-hook
 391             } %
 392         ] when
 393
 394         "windows-messages" "windows.messages" lookup [ , ] when*
 395     ] { } make ;
 396
 397 : strip-globals ( stripped-globals -- )
 398     strip-globals? [
 399         "Stripping globals" show
 400         global swap
 401         '[ drop _ member? not ] assoc-filter
 402         [ drop string? not ] assoc-filter ! strip CLI args
 403         sift-assoc
 404         21 set-special-object
 405     ] [ drop ] if ;
 406
 407 : strip-c-io ( -- )
 408     ! On all platforms, if deploy-io is 1, we strip out C streams.
 409     ! On Unix, if deploy-io is 3, we strip out C streams as well.
 410     ! On Windows, even if deploy-io is 3, C streams are still used
 411     ! for the console, so don't strip it there.
 412     strip-io?
 413     deploy-io get 3 = os windows? not and
 414     or [
 415         "Stripping C I/O" show
 416         "vocab:tools/deploy/shaker/strip-c-io.factor" run-file
 417     ] when ;
 418
 419 : compress ( pred post-process string -- )
 420     "Compressing " prepend show
 421     [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
 422     become ; inline
 423
 424 : compress-object? ( obj -- ? )
 425     {
 426         { [ dup array? ] [ empty? ] }
 427         { [ dup byte-array? ] [ drop t ] }
 428         { [ dup string? ] [ drop t ] }
 429         { [ dup wrapper? ] [ drop t ] }
 430         [ drop f ]
 431     } cond ;
 432
 433 : compress-objects ( -- )
 434     [ compress-object? ] [ ] "objects" compress ;
 435
 436 : remain-compiled ( old new -- old new )
 437     ! Quotations which were formerly compiled must remain
 438     ! compiled.
 439     2dup [
 440         2dup [ quot-compiled? ] [ quot-compiled? not ] bi* and
 441         [ nip jit-compile ] [ 2drop ] if
 442     ] 2each ;
 443
 444 : compress-quotations ( -- )
 445     [ quotation? ] [ remain-compiled ] "quotations" compress
 446     [ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ;
 447
 448 SYMBOL: deploy-vocab
 449
 450 : [:c] ( -- word ) ":c" "debugger" lookup ;
 451
 452 : [print-error] ( -- word ) "print-error" "debugger" lookup ;
 453
 454 : deploy-startup-quot ( word -- )
 455     [
 456         [ boot ] %
 457         startup-hooks get values concat %
 458         strip-debugger? [ , ] [
 459             ! Don't reference 'try' directly since we don't want
 460             ! to pull in the debugger and prettyprinter into every
 461             ! deployed app
 462             [:c]
 463             [print-error]
 464             '[
 465                 [ _ execute( obj -- ) ] [
 466                     _ execute( obj -- ) nl
 467                     _ execute( obj -- )
 468                 ] recover
 469             ] %
 470         ] if
 471         strip-io? [ [ flush ] % ] unless
 472         [ 0 exit ] %
 473     ] [ ] make
 474     set-startup-quot ;
 475
 476 : startup-stripper ( -- )
 477     t "quiet" set-global
 478     f output-stream set-global
 479     [ V{ "resource:" } clone vocab-roots set-global ]
 480     "vocabs.loader" startup-hooks get-global set-at ;
 481
 482 : next-method* ( method -- quot )
 483     [ "method-class" word-prop ]
 484     [ "method-generic" word-prop ] bi
 485     next-method ;
 486
 487 : calls-next-method? ( method -- ? )
 488     def>> flatten \ (call-next-method) swap member-eq? ;
 489
 490 : compute-next-methods ( -- )
 491     [ standard-generic? ] instances [
 492         "methods" word-prop values [ calls-next-method? ] filter
 493         [ dup next-method* "next-method" set-word-prop ] each
 494     ] each
 495     "vocab:tools/deploy/shaker/next-methods.factor" run-file ;
 496
 497 : (clear-megamorphic-cache) ( i array -- )
 498     ! Can't do any dispatch while clearing caches since that
 499     ! might leave them in an inconsistent state.
 500     2dup 1 slot < [
 501         2dup [ f ] 2dip set-array-nth
 502         [ 1 + ] dip (clear-megamorphic-cache)
 503     ] [ 2drop ] if ;
 504
 505 : clear-megamorphic-cache ( array -- )
 506     [ 0 ] dip (clear-megamorphic-cache) ;
 507
 508 : find-megamorphic-caches ( -- seq )
 509     "Finding megamorphic caches" show
 510     [ standard-generic? ] instances [ def>> third ] map ;
 511
 512 : clear-megamorphic-caches ( cache -- )
 513     "Clearing megamorphic caches" show
 514     [ clear-megamorphic-cache ] each ;
 515
 516 : write-vocab-manifest ( vocab-manifest-out -- )
 517     "Writing vocabulary manifest to " write dup print flush
 518     vocabs "VOCABS:" prefix
 519     deploy-libraries get [ libraries get at path>> ] map members "LIBRARIES:" prefix append
 520     swap utf8 set-file-lines ;
 521
 522 : prepare-deploy-libraries ( -- )
 523     "Preparing deployed libraries" show
 524     deploy-libraries get [
 525         libraries get [
 526             [ path>> >deployed-library-path ] [ abi>> ] bi <library>
 527         ] change-at
 528     ] each
 529
 530     [
 531         "deploy-libraries" "alien.libraries" lookup forget
 532         "deploy-library" "alien.libraries" lookup forget
 533         ">deployed-library-path" "alien.libraries.private" lookup forget
 534     ] with-compilation-unit ;
 535
 536 : strip ( vocab-manifest-out -- )
 537     [ write-vocab-manifest ] when*
 538     startup-stripper
 539     prepare-deploy-libraries
 540     strip-libc
 541     strip-destructors
 542     strip-call
 543     strip-cocoa
 544     strip-gtk-icon
 545     strip-debugger
 546     strip-ui-error-hook
 547     strip-specialized-arrays
 548     compute-next-methods
 549     strip-startup-hooks
 550     add-command-line-hook
 551     strip-c-io
 552     strip-default-methods
 553     strip-compiler-classes
 554     f 5 set-special-object ! we can't use the Factor debugger or Factor I/O anymore
 555     deploy-vocab get vocab-main deploy-startup-quot
 556     find-megamorphic-caches
 557     stripped-word-props
 558     stripped-globals strip-globals
 559     compress-objects
 560     compress-quotations
 561     strip-words
 562     clear-megamorphic-caches ;
 563
 564 : die-with ( error original-error -- * )
 565     #! We don't want DCE to drop the error before the die call!
 566     [ die 1 exit ] (( a -- * )) call-effect-unsafe ;
 567
 568 : die-with2 ( error original-error -- * )
 569     #! We don't want DCE to drop the error before the die call!
 570     [ die 1 exit ] (( a b -- * )) call-effect-unsafe ;
 571
 572 : deploy-error-handler ( quot -- )
 573     [
 574         strip-debugger?
 575         [ original-error get die-with2 ]
 576         ! Don't reference these words literally, if we're stripping the
 577         ! debugger out we don't want to load the prettyprinter at all
 578         [ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if
 579         1 exit
 580     ] recover ; inline
 581
 582 : (deploy) ( final-image vocab-manifest-out vocab config -- )
 583     #! Does the actual work of a deployment in the slave
 584     #! stage2 image
 585     [
 586         [
 587             strip-debugger? [
 588                 "debugger" require
 589                 "tools.errors" require
 590                 "inspector" require
 591                 deploy-ui? get [
 592                     "ui.debugger" require
 593                 ] when
 594             ] unless
 595             [ deploy-vocab set ] [ require ] [
 596                 vocab-main [
 597                     "Vocabulary has no MAIN: word." print flush 1 exit
 598                 ] unless
 599             ] tri
 600             strip
 601             "Saving final image" show
 602             save-image-and-exit
 603         ] deploy-error-handler
 604     ] bind ;
 605
 606 : do-deploy ( -- )
 607     "output-image" get
 608     "vocab-manifest-out" get
 609     "deploy-vocab" get
 610     "Deploying " write dup write "..." print
 611     "deploy-config" get parse-file first
 612     (deploy) ;
 613
 614 MAIN: do-deploy