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