basis/tools/deploy/shaker/shaker.factor

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