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