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