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