basis/tools/deploy/shaker/shaker.factor

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