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