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