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