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
   5 tools.deploy.config vocabs sequences words words.private memory
   6 kernel.private continuations io prettyprint vocabs.loader
   7 debugger system strings sets vectors quotations byte-arrays
   8 sorting compiler.units definitions ;
   9 QUALIFIED: bootstrap.stage2
  10 QUALIFIED: classes
  11 QUALIFIED: command-line
  12 QUALIFIED: compiler.errors.private
  13 QUALIFIED: continuations
  14 QUALIFIED: definitions
  15 QUALIFIED: init
  16 QUALIFIED: layouts
  17 QUALIFIED: listener
  18 QUALIFIED: prettyprint.config
  19 QUALIFIED: source-files
  20 QUALIFIED: vocabs
  21 IN: tools.deploy.shaker
  22
  23 ! This file is some hairy shit.
  24
  25 : strip-init-hooks ( -- )
  26     "Stripping startup hooks" show
  27     "cpu.x86" init-hooks get delete-at
  28     "command-line" init-hooks get delete-at
  29     "libc" init-hooks get delete-at
  30     "system" init-hooks get delete-at
  31     deploy-threads? get [
  32         "threads" init-hooks get delete-at
  33     ] unless
  34     native-io? [
  35         "io.thread" init-hooks get delete-at
  36     ] unless
  37     strip-io? [
  38         "io.files" init-hooks get delete-at
  39         "io.backend" init-hooks get delete-at
  40     ] when
  41     strip-dictionary? [
  42         "compiler.units" init-hooks get delete-at
  43         "tools.vocabs" init-hooks get delete-at
  44     ] when ;
  45
  46 : strip-debugger ( -- )
  47     strip-debugger? [
  48         "Stripping debugger" show
  49         "resource:basis/tools/deploy/shaker/strip-debugger.factor"
  50         run-file
  51     ] when ;
  52
  53 : strip-libc ( -- )
  54     "libc" vocab [
  55         "Stripping manual memory management debug code" show
  56         "resource:basis/tools/deploy/shaker/strip-libc.factor"
  57         run-file
  58     ] when ;
  59
  60 : strip-cocoa ( -- )
  61     "cocoa" vocab [
  62         "Stripping unused Cocoa methods" show
  63         "resource:basis/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         "Remaining word properties:\n" show
  89         [ props>> keys ] gather unparse show
  90     ] [
  91         H{ } clone '[
  92             [ [ _ [ ] cache ] map ] change-props drop
  93         ] each
  94     ] tri ;
  95
  96 : stripped-word-props ( -- seq )
  97     [
  98         strip-dictionary? deploy-compiler? get and [
  99             {
 100                 "combination"
 101                 "members"
 102                 "methods"
 103             } %
 104         ] when
 105
 106         strip-dictionary? [
 107             {
 108                 "alias"
 109                 "boa-check"
 110                 "cannot-infer"
 111                 "coercer"
 112                 "compiled-effect"
 113                 "compiled-generic-uses"
 114                 "compiled-uses"
 115                 "constraints"
 116                 "custom-inlining"
 117                 "declared-effect"
 118                 "default"
 119                 "default-method"
 120                 "default-output-classes"
 121                 "derived-from"
 122                 "engines"
 123                 "forgotten"
 124                 "identities"
 125                 "if-intrinsics"
 126                 "infer"
 127                 "inferred-effect"
 128                 "inline"
 129                 "inlined-block"
 130                 "input-classes"
 131                 "interval"
 132                 "intrinsics"
 133                 "lambda"
 134                 "loc"
 135                 "local-reader"
 136                 "local-reader?"
 137                 "local-writer"
 138                 "local-writer?"
 139                 "local?"
 140                 "macro"
 141                 "memo-quot"
 142                 "mixin"
 143                 "method-class"
 144                 "method-generic"
 145                 "modular-arithmetic"
 146                 "no-compile"
 147                 "optimizer-hooks"
 148                 "outputs"
 149                 "participants"
 150                 "predicate"
 151                 "predicate-definition"
 152                 "predicating"
 153                 "primitive"
 154                 "reader"
 155                 "reading"
 156                 "recursive"
 157                 "register"
 158                 "register-size"
 159                 "shuffle"
 160                 "slot-names"
 161                 "slots"
 162                 "special"
 163                 "specializer"
 164                 "step-into"
 165                 "step-into?"
 166                 "transform-n"
 167                 "transform-quot"
 168                 "tuple-dispatch-generic"
 169                 "type"
 170                 "writer"
 171                 "writing"
 172             } %
 173         ] when
 174
 175         strip-prettyprint? [
 176             {
 177                 "break-before"
 178                 "break-after"
 179                 "delimiter"
 180                 "flushable"
 181                 "foldable"
 182                 "inline"
 183                 "lambda"
 184                 "macro"
 185                 "memo-quot"
 186                 "parsing"
 187                 "word-style"
 188             } %
 189         ] when
 190     ] { } make ;
 191
 192 : strip-words ( props -- )
 193     [ word? ] instances
 194     deploy-word-props? get [ 2dup strip-word-props ] unless
 195     deploy-word-defs? get [ dup strip-word-defs ] unless
 196     strip-word-names? [ dup strip-word-names ] when
 197     2drop ;
 198
 199 : strip-vocab-globals ( except names -- words )
 200     [ child-vocabs [ words ] map concat ] map concat swap diff ;
 201
 202 : stripped-globals ( -- seq )
 203     [
 204         "callbacks" "alien.compiler" lookup ,
 205
 206         "inspector-hook" "inspector" lookup ,
 207
 208         {
 209             bootstrap.stage2:bootstrap-time
 210             continuations:error
 211             continuations:error-continuation
 212             continuations:error-thread
 213             continuations:restarts
 214             listener:error-hook
 215             init:init-hooks
 216             source-files:source-files
 217             input-stream
 218             output-stream
 219             error-stream
 220         } %
 221
 222         "io-thread" "io.thread" lookup ,
 223
 224         "mallocs" "libc.private" lookup ,
 225
 226         deploy-threads? [
 227             "initial-thread" "threads" lookup ,
 228         ] unless
 229
 230         strip-io? [ io-backend , ] when
 231
 232         { } {
 233             "alarms"
 234             "tools"
 235             "io.launcher"
 236             "random"
 237         } strip-vocab-globals %
 238
 239         strip-dictionary? [
 240             "libraries" "alien" lookup ,
 241
 242             { } { "cpu" } strip-vocab-globals %
 243
 244             {
 245                 gensym
 246                 name>char-hook
 247                 classes:class-and-cache
 248                 classes:class-not-cache
 249                 classes:class-or-cache
 250                 classes:class<=-cache
 251                 classes:classes-intersect-cache
 252                 classes:implementors-map
 253                 classes:update-map
 254                 command-line:main-vocab-hook
 255                 compiled-crossref
 256                 compiled-generic-crossref
 257                 recompile-hook
 258                 update-tuples-hook
 259                 definition-observers
 260                 definitions:crossref
 261                 interactive-vocabs
 262                 layouts:num-tags
 263                 layouts:num-types
 264                 layouts:tag-mask
 265                 layouts:tag-numbers
 266                 layouts:type-numbers
 267                 lexer-factory
 268                 listener:listener-hook
 269                 root-cache
 270                 vocab-roots
 271                 vocabs:dictionary
 272                 vocabs:load-vocab-hook
 273                 word
 274                 parser-notes
 275             } %
 276
 277             { } { "math.partial-dispatch" } strip-vocab-globals %
 278
 279             "peg-cache" "peg" lookup ,
 280         ] when
 281
 282         strip-prettyprint? [
 283             {
 284                 prettyprint.config:margin
 285                 prettyprint.config:string-limit?
 286                 prettyprint.config:boa-tuples?
 287                 prettyprint.config:tab-size
 288             } %
 289         ] when
 290
 291         strip-debugger? [
 292             {
 293                 compiler.errors.private:compiler-errors
 294                 continuations:thread-error-hook
 295             } %
 296         ] when
 297
 298         deploy-c-types? get [
 299             "c-types" "alien.c-types" lookup ,
 300         ] unless
 301
 302         deploy-ui? get [
 303             "ui-error-hook" "ui.gadgets.worlds" lookup ,
 304         ] when
 305
 306         "<value>" "stack-checker.state" lookup [ , ] when*
 307
 308         "windows-messages" "windows.messages" lookup [ , ] when*
 309
 310     ] { } make ;
 311
 312 : strip-globals ( stripped-globals -- )
 313     strip-globals? [
 314         "Stripping globals" show
 315         global swap
 316         '[ drop _ member? not ] assoc-filter
 317         [ drop string? not ] assoc-filter ! strip CLI args
 318         sift-assoc
 319         dup keys unparse show
 320         21 setenv
 321     ] [ drop ] if ;
 322
 323 : strip-c-io ( -- )
 324     deploy-io get 2 = [
 325         [
 326             c-io-backend forget
 327             "io.streams.c" forget-vocab
 328         ] with-compilation-unit
 329     ] unless ;
 330
 331 : compress ( pred string -- )
 332     "Compressing " prepend show
 333     instances
 334     dup H{ } clone [ [ ] cache ] curry map
 335     become ; inline
 336
 337 : compress-byte-arrays ( -- )
 338     [ byte-array? ] "byte arrays" compress ;
 339
 340 : compress-quotations ( -- )
 341     [ quotation? ] "quotations" compress ;
 342
 343 : compress-strings ( -- )
 344     [ string? ] "strings" compress ;
 345
 346 : finish-deploy ( final-image -- )
 347     "Finishing up" show
 348     >r { } set-datastack r>
 349     { } set-retainstack
 350     V{ } set-namestack
 351     V{ } set-catchstack
 352     "Saving final image" show
 353     [ save-image-and-exit ] call-clear ;
 354
 355 SYMBOL: deploy-vocab
 356
 357 : set-boot-quot* ( word -- )
 358     [
 359         \ boot ,
 360         init-hooks get values concat %
 361         ,
 362         strip-io? [ \ flush , ] unless
 363     ] [ ] make "Boot quotation: " show dup unparse show
 364     set-boot-quot ;
 365
 366 : init-stripper ( -- )
 367     t "quiet" set-global
 368     f output-stream set-global ;
 369
 370 : strip ( -- )
 371     init-stripper
 372     strip-libc
 373     strip-cocoa
 374     strip-debugger
 375     strip-init-hooks
 376     strip-c-io
 377     f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
 378     deploy-vocab get vocab-main set-boot-quot*
 379     stripped-word-props >r
 380     stripped-globals strip-globals
 381     r> strip-words
 382     compress-byte-arrays
 383     compress-quotations
 384     compress-strings
 385     H{ } clone classes:next-method-quot-cache set-global ;
 386
 387 : (deploy) ( final-image vocab config -- )
 388     #! Does the actual work of a deployment in the slave
 389     #! stage2 image
 390     [
 391         [
 392             deploy-vocab set
 393             deploy-vocab get require
 394             strip
 395             finish-deploy
 396         ] [
 397             print-error flush 1 exit
 398         ] recover
 399     ] bind ;
 400
 401 : do-deploy ( -- )
 402     "output-image" get
 403     "deploy-vocab" get
 404     "Deploying " write dup write "..." print
 405     dup deploy-config dup .
 406     (deploy) ;
 407
 408 MAIN: do-deploy