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