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: accessors qualified io.streams.c init fry namespaces
   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 ;
   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: 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 >>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 : 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 (>>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         "inspector-hook" "inspector" lookup ,
 158
 159         {
 160             bootstrap.stage2:bootstrap-time
 161             continuations:error
 162             continuations:error-continuation
 163             continuations:error-thread
 164             continuations:restarts
 165             listener:error-hook
 166             init:init-hooks
 167             io.thread:io-thread
 168             libc.private:mallocs
 169             source-files:source-files
 170             input-stream
 171             output-stream
 172             error-stream
 173         } %
 174
 175         deploy-threads? [
 176             threads:initial-thread ,
 177         ] unless
 178
 179         strip-io? [ io.backend:io-backend , ] when
 180
 181         { } {
 182             "alarms"
 183             "tools"
 184             "io.launcher"
 185         } strip-vocab-globals %
 186
 187         strip-dictionary? [
 188             { } { "cpu" } strip-vocab-globals %
 189
 190             {
 191                 gensym
 192                 name>char-hook
 193                 classes:class-and-cache
 194                 classes:class-not-cache
 195                 classes:class-or-cache
 196                 classes:class<=-cache
 197                 classes:classes-intersect-cache
 198                 classes:implementors-map
 199                 classes:update-map
 200                 command-line:main-vocab-hook
 201                 compiled-crossref
 202                 compiler.units:recompile-hook
 203                 compiler.units:update-tuples-hook
 204                 definitions:crossref
 205                 interactive-vocabs
 206                 layouts:num-tags
 207                 layouts:num-types
 208                 layouts:tag-mask
 209                 layouts:tag-numbers
 210                 layouts:type-numbers
 211                 lexer-factory
 212                 listener:listener-hook
 213                 root-cache
 214                 vocab-roots
 215                 vocabs:dictionary
 216                 vocabs:load-vocab-hook
 217                 word
 218             } %
 219
 220             { } { "optimizer.math.partial" } strip-vocab-globals %
 221         ] when
 222
 223         strip-prettyprint? [
 224             {
 225                 prettyprint.config:margin
 226                 prettyprint.config:string-limit
 227                 prettyprint.config:tab-size
 228             } %
 229         ] when
 230
 231         strip-debugger? [
 232             {
 233                 compiler.errors.private:compiler-errors
 234                 continuations:thread-error-hook
 235             } %
 236         ] when
 237
 238         deploy-c-types? get [
 239             "c-types" "alien.c-types" lookup ,
 240         ] unless
 241
 242         deploy-ui? get [
 243             "ui-error-hook" "ui.gadgets.worlds" lookup ,
 244         ] when
 245
 246         "<computer>" "inference.dataflow" lookup [ , ] when*
 247
 248         "windows-messages" "windows.messages" lookup [ , ] when*
 249
 250     ] { } make ;
 251
 252 : strip-globals ( stripped-globals -- )
 253     strip-globals? [
 254         "Stripping globals" show
 255         global swap
 256         '[ drop , member? not ] assoc-filter
 257         [ drop string? not ] assoc-filter ! strip CLI args
 258         dup keys unparse show
 259         21 setenv
 260     ] [ drop ] if ;
 261
 262 : finish-deploy ( final-image -- )
 263     "Finishing up" show
 264     >r { } set-datastack r>
 265     { } set-retainstack
 266     V{ } set-namestack
 267     V{ } set-catchstack
 268
 269     "Saving final image" show
 270     [ save-image-and-exit ] call-clear ;
 271
 272 SYMBOL: deploy-vocab
 273
 274 : set-boot-quot* ( word -- )
 275     [
 276         \ boot ,
 277         init-hooks get values concat %
 278         ,
 279         strip-io? [ \ flush , ] unless
 280     ] [ ] make "Boot quotation: " write dup . flush
 281     set-boot-quot ;
 282
 283 : strip ( -- )
 284     strip-libc
 285     strip-cocoa
 286     strip-debugger
 287     strip-recompile-hook
 288     strip-init-hooks
 289     deploy-vocab get vocab-main set-boot-quot*
 290     stripped-word-props >r
 291     stripped-globals strip-globals
 292     r> strip-words ;
 293
 294 : (deploy) ( final-image vocab config -- )
 295     #! Does the actual work of a deployment in the slave
 296     #! stage2 image
 297     [
 298         [
 299             deploy-vocab set
 300             deploy-vocab get require
 301             strip
 302             finish-deploy
 303         ] [
 304             print-error flush 1 exit
 305         ] recover
 306     ] bind ;
 307
 308 : do-deploy ( -- )
 309     "output-image" get
 310     "deploy-vocab" get
 311     "Deploying " write dup write "..." print
 312     dup deploy-config dup .
 313     (deploy) ;
 314
 315 MAIN: do-deploy