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