basis/tools/deploy/shaker/shaker.factor

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