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