extra/tools/deploy/shaker/shaker.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: qualified io.streams.c init fry namespaces assocs kernel
   4 parser lexer strings.parser tools.deploy.config vocabs sequences
   5 words words.private memory kernel.private continuations io
   6 prettyprint vocabs.loader debugger system strings sets ;
   7 QUALIFIED: bootstrap.stage2
   8 QUALIFIED: classes
   9 QUALIFIED: command-line
  10 QUALIFIED: compiler.errors.private
  11 QUALIFIED: compiler.units
  12 QUALIFIED: continuations
  13 QUALIFIED: definitions
  14 QUALIFIED: init
  15 QUALIFIED: inspector
  16 QUALIFIED: io.backend
  17 QUALIFIED: io.thread
  18 QUALIFIED: layouts
  19 QUALIFIED: libc.private
  20 QUALIFIED: libc.private
  21 QUALIFIED: listener
  22 QUALIFIED: prettyprint.config
  23 QUALIFIED: source-files
  24 QUALIFIED: threads
  25 QUALIFIED: vocabs
  26 IN: tools.deploy.shaker
  27
  28 : strip-init-hooks ( -- )
  29     "Stripping startup hooks" show
  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:extra/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:extra/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:extra/tools/deploy/shaker/strip-cocoa.factor"
  60         run-file
  61     ] when ;
  62
  63 : strip-word-names ( words -- )
  64     "Stripping word names" show
  65     [ f over set-word-name f swap set-vocabulary>> ] each ;
  66
  67 : strip-word-defs ( words -- )
  68     "Stripping symbolic word definitions" show
  69     [ "no-def-strip" word-prop not ] filter
  70     [ [ ] swap set-word-def ] each ;
  71
  72 : strip-word-props ( stripped-props words -- )
  73     "Stripping word properties" show
  74     [
  75         [
  76             props>> swap
  77             '[ drop , member? not ] assoc-filter
  78             f assoc-like
  79         ] keep set-word-props
  80     ] with each ;
  81
  82 : stripped-word-props ( -- seq )
  83     [
  84         strip-dictionary? [
  85             {
  86                 "coercer"
  87                 "compiled-effect"
  88                 "compiled-uses"
  89                 "constraints"
  90                 "declared-effect"
  91                 "default-output-classes"
  92                 "identities"
  93                 "if-intrinsics"
  94                 "infer"
  95                 "inferred-effect"
  96                 "interval"
  97                 "intrinsics"
  98                 "loc"
  99                 "members"
 100                 "methods"
 101                 "combination"
 102                 "cannot-infer"
 103                 "default-method"
 104                 "optimizer-hooks"
 105                 "output-classes"
 106                 "participants"
 107                 "predicate"
 108                 "predicate-definition"
 109                 "predicating"
 110                 "slots"
 111                 "slot-names"
 112                 "specializer"
 113                 "step-into"
 114                 "step-into?"
 115                 "superclass"
 116                 "reading"
 117                 "writing"
 118                 "type"
 119                 "engines"
 120             } %
 121         ] when
 122
 123         strip-prettyprint? [
 124             {
 125                 "delimiter"
 126                 "flushable"
 127                 "foldable"
 128                 "inline"
 129                 "lambda"
 130                 "macro"
 131                 "memo-quot"
 132                 "parsing"
 133                 "word-style"
 134             } %
 135         ] when
 136     ] { } make ;
 137
 138 : strip-words ( props -- )
 139     [ word? ] instances
 140     deploy-word-props? get [ 2dup strip-word-props ] unless
 141     deploy-word-defs? get [ dup strip-word-defs ] unless
 142     strip-word-names? [ dup strip-word-names ] when
 143     2drop ;
 144
 145 : strip-recompile-hook ( -- )
 146     [ [ f ] { } map>assoc ]
 147     compiler.units:recompile-hook
 148     set-global ;
 149
 150 : strip-vocab-globals ( except names -- words )
 151     [ child-vocabs [ words ] map concat ] map concat swap diff ;
 152
 153 : stripped-globals ( -- seq )
 154     [
 155         "callbacks" "alien.compiler" lookup ,
 156
 157         {
 158             bootstrap.stage2:bootstrap-time
 159             continuations:error
 160             continuations:error-continuation
 161             continuations:error-thread
 162             continuations:restarts
 163             listener:error-hook
 164             init:init-hooks
 165             inspector:inspector-hook
 166             io.thread:io-thread
 167             libc.private:mallocs
 168             source-files:source-files
 169             input-stream
 170             output-stream
 171             error-stream
 172         } %
 173
 174         deploy-threads? [
 175             threads:initial-thread ,
 176         ] unless
 177
 178         strip-io? [ io.backend:io-backend , ] when
 179
 180         { } {
 181             "alarms"
 182             "tools"
 183             "io.launcher"
 184         } strip-vocab-globals %
 185
 186         strip-dictionary? [
 187             { } { "cpu" } strip-vocab-globals %
 188
 189             {
 190                 gensym
 191                 name>char-hook
 192                 classes:class-and-cache
 193                 classes:class-not-cache
 194                 classes:class-or-cache
 195                 classes:class<=-cache
 196                 classes:classes-intersect-cache
 197                 classes:implementors-map
 198                 classes:update-map
 199                 command-line:main-vocab-hook
 200                 compiled-crossref
 201                 compiler.units:recompile-hook
 202                 compiler.units:update-tuples-hook
 203                 definitions:crossref
 204                 interactive-vocabs
 205                 layouts:num-tags
 206                 layouts:num-types
 207                 layouts:tag-mask
 208                 layouts:tag-numbers
 209                 layouts:type-numbers
 210                 lexer-factory
 211                 listener:listener-hook
 212                 root-cache
 213                 vocab-roots
 214                 vocabs:dictionary
 215                 vocabs:load-vocab-hook
 216                 word
 217             } %
 218
 219             { } { "optimizer.math.partial" } strip-vocab-globals %
 220         ] when
 221
 222         strip-prettyprint? [
 223             {
 224                 prettyprint.config:margin
 225                 prettyprint.config:string-limit
 226                 prettyprint.config:tab-size
 227             } %
 228         ] when
 229
 230         strip-debugger? [
 231             {
 232                 compiler.errors.private:compiler-errors
 233                 continuations:thread-error-hook
 234             } %
 235         ] when
 236
 237         deploy-c-types? get [
 238             "c-types" "alien.c-types" lookup ,
 239         ] unless
 240
 241         deploy-ui? get [
 242             "ui-error-hook" "ui.gadgets.worlds" lookup ,
 243         ] when
 244
 245         "<computer>" "inference.dataflow" lookup [ , ] when*
 246
 247         "windows-messages" "windows.messages" lookup [ , ] when*
 248
 249     ] { } make ;
 250
 251 : strip-globals ( stripped-globals -- )
 252     strip-globals? [
 253         "Stripping globals" show
 254         global swap
 255         '[ drop , member? not ] assoc-filter
 256         [ drop string? not ] assoc-filter ! strip CLI args
 257         dup keys unparse show
 258         21 setenv
 259     ] [ drop ] if ;
 260
 261 : finish-deploy ( final-image -- )
 262     "Finishing up" show
 263     >r { } set-datastack r>
 264     { } set-retainstack
 265     V{ } set-namestack
 266     V{ } set-catchstack
 267
 268     "Saving final image" show
 269     [ save-image-and-exit ] call-clear ;
 270
 271 SYMBOL: deploy-vocab
 272
 273 : set-boot-quot* ( word -- )
 274     [
 275         \ boot ,
 276         init-hooks get values concat %
 277         ,
 278         strip-io? [ \ flush , ] unless
 279     ] [ ] make "Boot quotation: " write dup . flush
 280     set-boot-quot ;
 281
 282 : strip ( -- )
 283     strip-libc
 284     strip-cocoa
 285     strip-debugger
 286     strip-recompile-hook
 287     strip-init-hooks
 288     deploy-vocab get vocab-main set-boot-quot*
 289     stripped-word-props >r
 290     stripped-globals strip-globals
 291     r> strip-words ;
 292
 293 : (deploy) ( final-image vocab config -- )
 294     #! Does the actual work of a deployment in the slave
 295     #! stage2 image
 296     [
 297         [
 298             deploy-vocab set
 299             deploy-vocab get require
 300             strip
 301             finish-deploy
 302         ] [
 303             print-error flush 1 exit
 304         ] recover
 305     ] bind ;
 306
 307 : do-deploy ( -- )
 308     "output-image" get
 309     "deploy-vocab" get
 310     "Deploying " write dup write "..." print
 311     dup deploy-config dup .
 312     (deploy) ;
 313
 314 MAIN: do-deploy