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