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