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 memoize namespaces.private
  13 hashtables locals ;
  14 QUALIFIED: bootstrap.stage2
  15 QUALIFIED: classes.private
  16 QUALIFIED: compiler.crossref
  17 QUALIFIED: compiler.errors
  18 QUALIFIED: continuations
  19 QUALIFIED: definitions
  20 QUALIFIED: init
  21 QUALIFIED: layouts
  22 QUALIFIED: source-files
  23 QUALIFIED: source-files.errors
  24 QUALIFIED: vocabs
  25 QUALIFIED: vocabs.loader
  26 FROM: assocs => change-at ;
  27 FROM: namespaces => set ;
  28 FROM: sequences => change-nth ;
  29 FROM: sets => members ;
  30 IN: tools.deploy.shaker
  31
  32 ! This file is some hairy shit.
  33
  34 : add-command-line-hook ( -- )
  35     [
  36         (command-line) unclip
  37         executable set-global
  38         command-line set-global
  39     ] "command-line" startup-hooks get set-at ;
  40
  41 : strip-startup-hooks ( -- )
  42     "Stripping startup hooks" show
  43     {
  44         "alien.strings"
  45         "cpu.x86"
  46         "environment"
  47         "libc"
  48     }
  49     [ startup-hooks get delete-at ] each
  50     deploy-threads? get [
  51         "threads" startup-hooks get delete-at
  52     ] unless
  53     strip-io? [
  54         "io.backend" startup-hooks get delete-at
  55     ] when
  56     strip-dictionary? [
  57         {
  58             "vocabs"
  59             "vocabs.cache"
  60             "source-files.errors"
  61         } [ startup-hooks get delete-at ] each
  62     ] when ;
  63
  64 : strip-debugger ( -- )
  65     strip-debugger? "debugger" lookup-vocab and [
  66         "Stripping debugger" show
  67         "vocab:tools/deploy/shaker/strip-debugger.factor"
  68         run-file
  69     ] when ;
  70
  71 : strip-ui-error-hook ( -- )
  72     strip-debugger? deploy-ui? get and "ui" lookup-vocab and [
  73         "Installing generic UI error hook" show
  74         "vocab:tools/deploy/shaker/strip-ui-error-hook.factor"
  75         run-file
  76     ] when ;
  77
  78 : strip-libc ( -- )
  79     "libc" lookup-vocab [
  80         "Stripping manual memory management debug code" show
  81         "vocab:tools/deploy/shaker/strip-libc.factor"
  82         run-file
  83     ] when ;
  84
  85 : strip-destructors ( -- )
  86     "Stripping destructor debug code" show
  87     "vocab:tools/deploy/shaker/strip-destructors.factor"
  88     run-file ;
  89
  90 : strip-call ( -- )
  91     "Stripping stack effect checking from call( and execute(" show
  92     "vocab:tools/deploy/shaker/strip-call.factor" run-file ;
  93
  94 : strip-cocoa ( -- )
  95     "cocoa" lookup-vocab [
  96         "Stripping unused Cocoa methods" show
  97         "vocab:tools/deploy/shaker/strip-cocoa.factor"
  98         run-file
  99     ] when ;
 100
 101 : strip-gobject ( -- )
 102     "gobject-introspection.types" lookup-vocab [
 103         "Stripping GObject type info" show
 104         "vocab:tools/deploy/shaker/strip-gobject.factor"
 105         run-file
 106     ] when ;
 107
 108 : strip-gtk-icon ( -- )
 109     "ui.backend.gtk" lookup-vocab [
 110         "Stripping GTK icon loading code" show
 111         "vocab:tools/deploy/shaker/strip-gtk-icon.factor"
 112         run-file
 113     ] when ;
 114
 115 : strip-specialized-arrays ( -- )
 116     strip-dictionary? "specialized-arrays" lookup-vocab and [
 117         "Stripping specialized arrays" show
 118         "vocab:tools/deploy/shaker/strip-specialized-arrays.factor"
 119         run-file
 120     ] when ;
 121
 122 : strip-word-names ( words -- )
 123     "Stripping word names" show
 124     [ f >>name f >>vocabulary drop ] each ;
 125
 126 : strip-word-defs ( words -- )
 127     "Stripping symbolic word definitions" show
 128     [ "no-def-strip" word-prop ] reject
 129     [ [ ] >>def drop ] each ;
 130
 131 : strip-word-props ( stripped-props words -- )
 132     "Stripping word properties" show
 133     swap '[
 134         [
 135             [ drop _ member? not ] assoc-filter sift-values
 136             >alist f like
 137         ] change-props drop
 138     ] each ;
 139
 140 : stripped-word-props ( -- seq )
 141     [
 142         strip-dictionary? [
 143             {
 144                 "alias"
 145                 "boa-check"
 146                 "coercer"
 147                 "combination"
 148                 "generic-call-sites"
 149                 "effect-dependencies"
 150                 "definition-dependencies"
 151                 "conditional-dependencies"
 152                 "dependency-checks"
 153                 "constant"
 154                 "constraints"
 155                 "custom-inlining"
 156                 "decision-tree"
 157                 "declared-effect"
 158                 "default"
 159                 "default-method"
 160                 "default-output-classes"
 161                 "derived-from"
 162                 "ebnf-parser"
 163                 "engines"
 164                 "forgotten"
 165                 "identities"
 166                 "inline"
 167                 "inlined-block"
 168                 "input-classes"
 169                 "instances"
 170                 "interval"
 171                 "intrinsic"
 172                 "lambda"
 173                 "loc"
 174                 "local-reader"
 175                 "local-reader?"
 176                 "local-writer"
 177                 "local-writer?"
 178                 "local?"
 179                 "low-order"
 180                 "macro"
 181                 "members"
 182                 "memo-quot"
 183                 "methods"
 184                 "method-class"
 185                 "method-generic"
 186                 "modular-arithmetic"
 187                 "no-compile"
 188                 "owner-generic"
 189                 "outputs"
 190                 "participants"
 191                 "predicate"
 192                 "predicate-definition"
 193                 "predicating"
 194                 "reader"
 195                 "reading"
 196                 "recursive"
 197                 "register"
 198                 "register-size"
 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 ( -- seq )
 247     { "compiler" "stack-checker" }
 248     [ child-vocabs [ words ] map concat [ class? ] filter ]
 249     map concat unique ;
 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 _ key? not ] assoc-filter
 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     [ child-vocabs [ 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                 word
 372                 parser-quiet?
 373             } %
 374
 375             { } { "layouts" } vocab-tree-globals %
 376
 377             { } { "math.partial-dispatch" } vocab-tree-globals %
 378
 379             { } { "math.vectors.simd" } vocab-tree-globals %
 380
 381             { } { "peg" } vocab-tree-globals %
 382         ] when
 383
 384         strip-prettyprint? [
 385             { } { "prettyprint.config" } vocab-tree-globals %
 386         ] when
 387
 388         strip-debugger? [
 389             \ compiler.errors:compiler-errors ,
 390         ] when
 391     ] { } make ;
 392
 393 : cleared-globals ( -- seq )
 394     [
 395
 396         {
 397             init:startup-hooks
 398             input-stream
 399             output-stream
 400             error-stream
 401             vm
 402             image
 403             current-directory
 404         } %
 405
 406         "io-thread" "io.thread" lookup-word ,
 407
 408         deploy-threads? [
 409             "initial-thread" "threads" lookup-word ,
 410         ] unless
 411
 412         strip-io? [ io-backend , ] when
 413
 414         { } {
 415             "timers"
 416             "io.launcher"
 417             "random"
 418         } vocab-tree-globals %
 419
 420         "windows-messages" "windows.messages" lookup-word [ , ] when*
 421     ] { } make ;
 422
 423 : strip-global? ( name stripped-globals -- ? )
 424     '[ _ member? ] [ tuple? ] bi or ;
 425
 426 : clear-global? ( name cleared-globals -- ? )
 427     '[ _ member? ] [ string? ] bi or ;
 428
 429 : strip-globals ( -- )
 430     strip-globals? [| |
 431         "Stripping globals" show
 432         stripped-globals :> to-strip
 433         cleared-globals :> to-clear
 434         global boxes>>
 435         [ drop to-strip strip-global? not ] assoc-filter!
 436         [
 437             [
 438                 swap to-clear clear-global?
 439                 [ f swap value<< ] [ drop ] if
 440             ] assoc-each
 441         ] [ rehash ] bi
 442     ] when ;
 443
 444 : strip-c-io ( -- )
 445     ! On all platforms, if deploy-io is 1, we strip out C streams.
 446     ! On Unix, if deploy-io is 3, we strip out C streams as well.
 447     ! On Windows, even if deploy-io is 3, C streams are still used
 448     ! for the console, so don't strip it there.
 449     strip-io?
 450     native-io? os windows? not and
 451     or [
 452         "Stripping C I/O" show
 453         "vocab:tools/deploy/shaker/strip-c-io.factor" run-file
 454     ] when ;
 455
 456 : compress ( pred post-process string -- )
 457     "Compressing " prepend show
 458     [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
 459     become ; inline
 460
 461 : compress-object? ( obj -- ? )
 462     {
 463         { [ dup array? ] [ empty? ] }
 464         { [ dup byte-array? ] [ drop t ] }
 465         { [ dup string? ] [ drop t ] }
 466         { [ dup wrapper? ] [ drop t ] }
 467         [ drop f ]
 468     } cond ;
 469
 470 : compress-objects ( -- )
 471     [ compress-object? ] [ ] "objects" compress ;
 472
 473 : remain-compiled ( old new -- old new )
 474     ! Quotations which were formerly compiled must remain
 475     ! compiled.
 476     2dup [
 477         2dup [ quot-compiled? ] [ quot-compiled? not ] bi* and
 478         [ nip jit-compile ] [ 2drop ] if
 479     ] 2each ;
 480
 481 : compress-quotations ( -- )
 482     [ quotation? ] [ remain-compiled ] "quotations" compress
 483     [ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ;
 484
 485 SYMBOL: deploy-vocab
 486
 487 : [:c] ( -- word ) ":c" "debugger" lookup-word ;
 488
 489 : [print-error] ( -- word ) "print-error" "debugger" lookup-word ;
 490
 491 : deploy-startup-quot ( word -- )
 492     [
 493         [ boot ] %
 494         startup-hooks get values concat %
 495         strip-debugger? [ , ] [
 496             ! Don't reference 'try' directly since we don't want
 497             ! to pull in the debugger and prettyprinter into every
 498             ! deployed app
 499             [:c]
 500             [print-error]
 501             '[
 502                 [ _ execute( obj -- ) ] [
 503                     _ execute( obj -- ) nl
 504                     _ execute( obj -- )
 505                 ] recover
 506             ] %
 507         ] if
 508         strip-io? [ [ flush ] % ] unless
 509         [ 0 exit ] %
 510     ] [ ] make
 511     set-startup-quot ;
 512
 513 : startup-stripper ( -- )
 514     t parser-quiet? set-global
 515     f output-stream set-global
 516     [ V{ "resource:" } clone vocab-roots set-global ]
 517     "vocabs.loader" startup-hooks get-global set-at ;
 518
 519 : next-method* ( method -- quot )
 520     [ "method-class" word-prop ]
 521     [ "method-generic" word-prop ] bi
 522     next-method ;
 523
 524 : calls-next-method? ( method -- ? )
 525     def>> flatten \ (call-next-method) swap member-eq? ;
 526
 527 : compute-next-methods ( -- )
 528     [ standard-generic? ] instances [
 529         "methods" word-prop values [ calls-next-method? ] filter
 530         [ dup next-method* "next-method" set-word-prop ] each
 531     ] each
 532     "vocab:tools/deploy/shaker/next-methods.factor" run-file ;
 533
 534 : (clear-megamorphic-cache) ( i array -- )
 535     ! Can't do any dispatch while clearing caches since that
 536     ! might leave them in an inconsistent state.
 537     2dup 1 slot < [
 538         2dup [ f ] 2dip set-array-nth
 539         [ 1 + ] dip (clear-megamorphic-cache)
 540     ] [ 2drop ] if ;
 541
 542 : clear-megamorphic-cache ( array -- )
 543     [ 0 ] dip (clear-megamorphic-cache) ;
 544
 545 : find-megamorphic-caches ( -- seq )
 546     "Finding megamorphic caches" show
 547     [ standard-generic? ] instances [ def>> third ] map ;
 548
 549 : clear-megamorphic-caches ( cache -- )
 550     "Clearing megamorphic caches" show
 551     [ clear-megamorphic-cache ] each ;
 552
 553 : write-vocab-manifest ( vocab-manifest-out -- )
 554     "Writing vocabulary manifest to " write dup print flush
 555     vocabs "VOCABS:" prefix
 556     deploy-libraries get [ lookup-library path>> ] map members
 557     "LIBRARIES:" prefix append
 558     swap utf8 set-file-lines ;
 559
 560 : prepare-deploy-libraries ( -- )
 561     "Preparing deployed libraries" show
 562     deploy-libraries get [
 563         libraries get [
 564             [ path>> >deployed-library-path ] [ abi>> ] bi make-library
 565         ] change-at
 566     ] each
 567
 568     [
 569         "deploy-libraries" "alien.libraries" lookup-word forget
 570         "deploy-library" "alien.libraries" lookup-word forget
 571         ">deployed-library-path" "alien.libraries.private" lookup-word forget
 572     ] with-compilation-unit ;
 573
 574 : strip ( vocab-manifest-out -- )
 575     [ write-vocab-manifest ] when*
 576     startup-stripper
 577     prepare-deploy-libraries
 578     strip-libc
 579     strip-destructors
 580     strip-call
 581     strip-cocoa
 582     strip-gobject
 583     strip-gtk-icon
 584     strip-debugger
 585     strip-ui-error-hook
 586     strip-specialized-arrays
 587     compute-next-methods
 588     strip-startup-hooks
 589     add-command-line-hook
 590     strip-c-io
 591     strip-default-methods
 592     strip-compiler-classes
 593     ! we can't use the Factor debugger or Factor I/O anymore
 594     f ERROR-HANDLER-QUOT set-special-object
 595     deploy-vocab get vocab-main deploy-startup-quot
 596     find-megamorphic-caches
 597     stripped-word-props
 598     strip-globals
 599     compress-objects
 600     compress-quotations
 601     strip-words
 602     strip-memoized
 603     clear-megamorphic-caches ;
 604
 605 : die-with ( error original-error -- * )
 606     #! We don't want DCE to drop the error before the die call!
 607     [ die 1 exit ] ( a -- * ) call-effect-unsafe ;
 608
 609 : die-with2 ( error original-error -- * )
 610     #! We don't want DCE to drop the error before the die call!
 611     [ die 1 exit ] ( a b -- * ) call-effect-unsafe ;
 612
 613 : deploy-error-handler ( quot -- )
 614     [
 615         strip-debugger?
 616         [ original-error get die-with2 ]
 617         ! Don't reference these words literally, if we're stripping the
 618         ! debugger out we don't want to load the prettyprinter at all
 619         [ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if
 620         1 exit
 621     ] recover ; inline
 622
 623 : (deploy) ( final-image vocab-manifest-out vocab config -- )
 624     #! Does the actual work of a deployment in the slave
 625     #! stage2 image
 626     [
 627         [
 628             strip-debugger? [
 629                 "debugger" require
 630                 "tools.errors" require
 631                 "inspector" require
 632                 deploy-ui? get [
 633                     "ui.debugger" require
 634                 ] when
 635             ] unless
 636             [ deploy-vocab set ] [ require ] [
 637                 vocab-main [
 638                     "Vocabulary has no MAIN: word." print flush 1 exit
 639                 ] unless
 640             ] tri
 641             strip
 642             "Saving final image" show
 643             save-image-and-exit
 644         ] deploy-error-handler
 645     ] with-variables ;
 646
 647 : do-deploy ( -- )
 648     "output-image" get
 649     "vocab-manifest-out" get
 650     "deploy-vocab" get
 651     "Deploying " write dup write "..." print
 652     "deploy-config" get parse-file first
 653     (deploy) ;
 654
 655 MAIN: do-deploy