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