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