411 lines
11 KiB
Factor
Executable File
411 lines
11 KiB
Factor
Executable File
! Copyright (C) 2007, 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors qualified io.backend io.streams.c init fry
|
|
namespaces make assocs kernel parser lexer strings.parser
|
|
tools.deploy.config vocabs sequences words words.private memory
|
|
kernel.private continuations io prettyprint vocabs.loader
|
|
debugger system strings sets vectors quotations byte-arrays
|
|
sorting compiler.units definitions generic generic.standard ;
|
|
QUALIFIED: bootstrap.stage2
|
|
QUALIFIED: classes
|
|
QUALIFIED: command-line
|
|
QUALIFIED: compiler.errors
|
|
QUALIFIED: continuations
|
|
QUALIFIED: definitions
|
|
QUALIFIED: init
|
|
QUALIFIED: layouts
|
|
QUALIFIED: prettyprint.config
|
|
QUALIFIED: source-files
|
|
QUALIFIED: vocabs
|
|
IN: tools.deploy.shaker
|
|
|
|
! This file is some hairy shit.
|
|
|
|
: strip-init-hooks ( -- )
|
|
"Stripping startup hooks" show
|
|
"cpu.x86" init-hooks get delete-at
|
|
"command-line" init-hooks get delete-at
|
|
"libc" init-hooks get delete-at
|
|
"system" init-hooks get delete-at
|
|
deploy-threads? get [
|
|
"threads" init-hooks get delete-at
|
|
] unless
|
|
native-io? [
|
|
"io.thread" init-hooks get delete-at
|
|
] unless
|
|
strip-io? [
|
|
"io.files" init-hooks get delete-at
|
|
"io.backend" init-hooks get delete-at
|
|
] when
|
|
strip-dictionary? [
|
|
"compiler.units" init-hooks get delete-at
|
|
"tools.vocabs" init-hooks get delete-at
|
|
] when ;
|
|
|
|
: strip-debugger ( -- )
|
|
strip-debugger? [
|
|
"Stripping debugger" show
|
|
"resource:basis/tools/deploy/shaker/strip-debugger.factor"
|
|
run-file
|
|
] when ;
|
|
|
|
: strip-libc ( -- )
|
|
"libc" vocab [
|
|
"Stripping manual memory management debug code" show
|
|
"resource:basis/tools/deploy/shaker/strip-libc.factor"
|
|
run-file
|
|
] when ;
|
|
|
|
: strip-cocoa ( -- )
|
|
"cocoa" vocab [
|
|
"Stripping unused Cocoa methods" show
|
|
"resource:basis/tools/deploy/shaker/strip-cocoa.factor"
|
|
run-file
|
|
] when ;
|
|
|
|
: strip-word-names ( words -- )
|
|
"Stripping word names" show
|
|
[ f >>name f >>vocabulary drop ] each ;
|
|
|
|
: strip-word-defs ( words -- )
|
|
"Stripping symbolic word definitions" show
|
|
[ "no-def-strip" word-prop not ] filter
|
|
[ [ ] >>def drop ] each ;
|
|
|
|
: sift-assoc ( assoc -- assoc' ) [ nip ] assoc-filter ;
|
|
|
|
: strip-word-props ( stripped-props words -- )
|
|
"Stripping word properties" show
|
|
[
|
|
swap '[
|
|
[
|
|
[ drop _ member? not ] assoc-filter sift-assoc
|
|
>alist f like
|
|
] change-props drop
|
|
] each
|
|
] [
|
|
"Remaining word properties:\n" show
|
|
[ props>> keys ] gather unparse show
|
|
] [
|
|
H{ } clone '[
|
|
[ [ _ [ ] cache ] map ] change-props drop
|
|
] each
|
|
] tri ;
|
|
|
|
: stripped-word-props ( -- seq )
|
|
[
|
|
strip-dictionary? [
|
|
{
|
|
"alias"
|
|
"boa-check"
|
|
"cannot-infer"
|
|
"coercer"
|
|
"combination"
|
|
"compiled-effect"
|
|
"compiled-generic-uses"
|
|
"compiled-uses"
|
|
"constraints"
|
|
"custom-inlining"
|
|
"declared-effect"
|
|
"default"
|
|
"default-method"
|
|
"default-output-classes"
|
|
"derived-from"
|
|
"engines"
|
|
"forgotten"
|
|
"identities"
|
|
"if-intrinsics"
|
|
"infer"
|
|
"inferred-effect"
|
|
"inline"
|
|
"inlined-block"
|
|
"input-classes"
|
|
"interval"
|
|
"intrinsics"
|
|
"lambda"
|
|
"loc"
|
|
"local-reader"
|
|
"local-reader?"
|
|
"local-writer"
|
|
"local-writer?"
|
|
"local?"
|
|
"macro"
|
|
"members"
|
|
"memo-quot"
|
|
"methods"
|
|
"mixin"
|
|
"method-class"
|
|
"method-generic"
|
|
"modular-arithmetic"
|
|
"no-compile"
|
|
"optimizer-hooks"
|
|
"outputs"
|
|
"participants"
|
|
"predicate"
|
|
"predicate-definition"
|
|
"predicating"
|
|
"primitive"
|
|
"reader"
|
|
"reading"
|
|
"recursive"
|
|
"register"
|
|
"register-size"
|
|
"shuffle"
|
|
"slot-names"
|
|
"slots"
|
|
"special"
|
|
"specializer"
|
|
"step-into"
|
|
"step-into?"
|
|
"transform-n"
|
|
"transform-quot"
|
|
"tuple-dispatch-generic"
|
|
"type"
|
|
"writer"
|
|
"writing"
|
|
} %
|
|
] when
|
|
|
|
strip-prettyprint? [
|
|
{
|
|
"break-before"
|
|
"break-after"
|
|
"delimiter"
|
|
"flushable"
|
|
"foldable"
|
|
"inline"
|
|
"lambda"
|
|
"macro"
|
|
"memo-quot"
|
|
"parsing"
|
|
"word-style"
|
|
} %
|
|
] when
|
|
] { } make ;
|
|
|
|
: strip-words ( props -- )
|
|
[ word? ] instances
|
|
deploy-word-props? get [ 2dup strip-word-props ] unless
|
|
deploy-word-defs? get [ dup strip-word-defs ] unless
|
|
strip-word-names? [ dup strip-word-names ] when
|
|
2drop ;
|
|
|
|
: strip-vocab-globals ( except names -- words )
|
|
[ child-vocabs [ words ] map concat ] map concat swap diff ;
|
|
|
|
: stripped-globals ( -- seq )
|
|
[
|
|
"inspector-hook" "inspector" lookup ,
|
|
|
|
{
|
|
continuations:error
|
|
continuations:error-continuation
|
|
continuations:error-thread
|
|
continuations:restarts
|
|
init:init-hooks
|
|
source-files:source-files
|
|
input-stream
|
|
output-stream
|
|
error-stream
|
|
} %
|
|
|
|
"io-thread" "io.thread" lookup ,
|
|
|
|
"mallocs" "libc.private" lookup ,
|
|
|
|
deploy-threads? [
|
|
"initial-thread" "threads" lookup ,
|
|
] unless
|
|
|
|
strip-io? [ io-backend , ] when
|
|
|
|
{ } {
|
|
"alarms"
|
|
"tools"
|
|
"io.launcher"
|
|
"random"
|
|
"compiler"
|
|
"stack-checker"
|
|
"bootstrap"
|
|
"listener"
|
|
} strip-vocab-globals %
|
|
|
|
strip-dictionary? [
|
|
"libraries" "alien" lookup ,
|
|
|
|
{ } { "cpu" } strip-vocab-globals %
|
|
|
|
{
|
|
gensym
|
|
name>char-hook
|
|
classes:next-method-quot-cache
|
|
classes:class-and-cache
|
|
classes:class-not-cache
|
|
classes:class-or-cache
|
|
classes:class<=-cache
|
|
classes:classes-intersect-cache
|
|
classes:implementors-map
|
|
classes:update-map
|
|
command-line:main-vocab-hook
|
|
compiled-crossref
|
|
compiled-generic-crossref
|
|
recompile-hook
|
|
update-tuples-hook
|
|
remake-generics-hook
|
|
definition-observers
|
|
definitions:crossref
|
|
interactive-vocabs
|
|
layouts:num-tags
|
|
layouts:num-types
|
|
layouts:tag-mask
|
|
layouts:tag-numbers
|
|
layouts:type-numbers
|
|
lexer-factory
|
|
print-use-hook
|
|
root-cache
|
|
vocab-roots
|
|
vocabs:dictionary
|
|
vocabs:load-vocab-hook
|
|
word
|
|
parser-notes
|
|
} %
|
|
|
|
{ } { "math.partial-dispatch" } strip-vocab-globals %
|
|
|
|
"peg-cache" "peg" lookup ,
|
|
] when
|
|
|
|
strip-prettyprint? [
|
|
{
|
|
prettyprint.config:margin
|
|
prettyprint.config:string-limit?
|
|
prettyprint.config:boa-tuples?
|
|
prettyprint.config:tab-size
|
|
} %
|
|
] when
|
|
|
|
strip-debugger? [
|
|
{
|
|
compiler.errors:compiler-errors
|
|
continuations:thread-error-hook
|
|
} %
|
|
] when
|
|
|
|
deploy-c-types? get [
|
|
"c-types" "alien.c-types" lookup ,
|
|
] unless
|
|
|
|
deploy-ui? get [
|
|
"ui-error-hook" "ui.gadgets.worlds" lookup ,
|
|
] when
|
|
|
|
"windows-messages" "windows.messages" lookup [ , ] when*
|
|
] { } make ;
|
|
|
|
: strip-globals ( stripped-globals -- )
|
|
strip-globals? [
|
|
"Stripping globals" show
|
|
global swap
|
|
'[ drop _ member? not ] assoc-filter
|
|
[ drop string? not ] assoc-filter ! strip CLI args
|
|
sift-assoc
|
|
dup keys unparse show
|
|
21 setenv
|
|
] [ drop ] if ;
|
|
|
|
: strip-c-io ( -- )
|
|
deploy-io get 2 = os windows? or [
|
|
[
|
|
c-io-backend forget
|
|
"io.streams.c" forget-vocab
|
|
] with-compilation-unit
|
|
] unless ;
|
|
|
|
: compress ( pred string -- )
|
|
"Compressing " prepend show
|
|
instances
|
|
dup H{ } clone [ [ ] cache ] curry map
|
|
become ; inline
|
|
|
|
: compress-byte-arrays ( -- )
|
|
[ byte-array? ] "byte arrays" compress ;
|
|
|
|
: compress-quotations ( -- )
|
|
[ quotation? ] "quotations" compress ;
|
|
|
|
: compress-strings ( -- )
|
|
[ string? ] "strings" compress ;
|
|
|
|
: finish-deploy ( final-image -- )
|
|
"Finishing up" show
|
|
>r { } set-datastack r>
|
|
{ } set-retainstack
|
|
V{ } set-namestack
|
|
V{ } set-catchstack
|
|
"Saving final image" show
|
|
[ save-image-and-exit ] call-clear ;
|
|
|
|
SYMBOL: deploy-vocab
|
|
|
|
: set-boot-quot* ( word -- )
|
|
[
|
|
\ boot ,
|
|
init-hooks get values concat %
|
|
,
|
|
strip-io? [ \ flush , ] unless
|
|
] [ ] make "Boot quotation: " show dup unparse show
|
|
set-boot-quot ;
|
|
|
|
: init-stripper ( -- )
|
|
t "quiet" set-global
|
|
f output-stream set-global ;
|
|
|
|
: compute-next-methods ( -- )
|
|
[ standard-generic? ] instances [
|
|
"methods" word-prop [
|
|
nip
|
|
dup next-method-quot "next-method-quot" set-word-prop
|
|
] assoc-each
|
|
] each
|
|
"resource:basis/tools/deploy/shaker/next-methods.factor" run-file ;
|
|
|
|
: strip ( -- )
|
|
init-stripper
|
|
strip-libc
|
|
strip-cocoa
|
|
strip-debugger
|
|
compute-next-methods
|
|
strip-init-hooks
|
|
strip-c-io
|
|
f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
|
|
deploy-vocab get vocab-main set-boot-quot*
|
|
stripped-word-props >r
|
|
stripped-globals strip-globals
|
|
r> strip-words
|
|
compress-byte-arrays
|
|
compress-quotations
|
|
compress-strings ;
|
|
|
|
: (deploy) ( final-image vocab config -- )
|
|
#! Does the actual work of a deployment in the slave
|
|
#! stage2 image
|
|
[
|
|
[
|
|
deploy-vocab set
|
|
deploy-vocab get require
|
|
strip
|
|
finish-deploy
|
|
] [
|
|
print-error flush 1 exit
|
|
] recover
|
|
] bind ;
|
|
|
|
: do-deploy ( -- )
|
|
"output-image" get
|
|
"deploy-vocab" get
|
|
"Deploying " write dup write "..." print
|
|
dup deploy-config dup .
|
|
(deploy) ;
|
|
|
|
MAIN: do-deploy
|