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