Clean up and update tools.deploy
Slava Pestov
parent
43c83bb4e0
commit
48d8d60c7c
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2007 Slava Pestov.
|
! Copyright (C) 2007 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io io.files io.launcher kernel namespaces sequences
|
USING: io io.files io.launcher kernel namespaces sequences
|
||||||
system cocoa.plists cocoa.application tools.deploy assocs
|
system cocoa.plists cocoa.application tools.deploy
|
||||||
hashtables prettyprint ;
|
tools.deploy.config assocs hashtables prettyprint ;
|
||||||
IN: tools.deploy.app
|
IN: tools.deploy.app
|
||||||
|
|
||||||
: mkdir ( path -- )
|
: mkdir ( path -- )
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,105 @@
|
||||||
|
USING: help.markup help.syntax words alien.c-types assocs
|
||||||
|
kernel ;
|
||||||
|
IN: tools.deploy.config
|
||||||
|
|
||||||
|
ARTICLE: "deploy-config" "Deployment configuration"
|
||||||
|
"The deployment configuration is a key/value mapping stored in the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If this file does not exist, the default deployment configuration is used:"
|
||||||
|
{ $subsection default-config }
|
||||||
|
"The deployment configuration can be read and written with a pair of words:"
|
||||||
|
{ $subsection deploy-config }
|
||||||
|
{ $subsection set-deploy-config }
|
||||||
|
"A utility word is provided to load the configuration, change a flag, and store it back to disk:"
|
||||||
|
{ $subsection set-deploy-flag } ;
|
||||||
|
|
||||||
|
ARTICLE: "deploy-flags" "Deployment flags"
|
||||||
|
"There are two types of flags. The first set controls the major subsystems which are to be included in the deployment image:"
|
||||||
|
{ $subsection deploy-math? }
|
||||||
|
{ $subsection deploy-compiled? }
|
||||||
|
{ $subsection deploy-io? }
|
||||||
|
{ $subsection deploy-ui? }
|
||||||
|
"The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:"
|
||||||
|
{ $subsection strip-globals? }
|
||||||
|
{ $subsection strip-word-props? }
|
||||||
|
{ $subsection strip-word-names? }
|
||||||
|
{ $subsection strip-dictionary? }
|
||||||
|
{ $subsection strip-debugger? }
|
||||||
|
{ $subsection strip-prettyprint? }
|
||||||
|
{ $subsection strip-c-types? } ;
|
||||||
|
|
||||||
|
ARTICLE: "prepare-deploy" "Preparing to deploy an application"
|
||||||
|
"In order to deploy an application as a stand-alone image, the application's vocabulary must first be given a " { $link POSTPONE: MAIN: } " hook. Then, a " { $emphasis "deployment configuration" } " must be created."
|
||||||
|
{ $subsection "deploy-config" }
|
||||||
|
{ $subsection "deploy-flags" } ;
|
||||||
|
|
||||||
|
ABOUT: "prepare-deploy"
|
||||||
|
|
||||||
|
HELP: strip-globals?
|
||||||
|
{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed variables from the global namespace."
|
||||||
|
$nl
|
||||||
|
"On by default. Disable this if the heuristics strip out required variables." } ;
|
||||||
|
|
||||||
|
HELP: strip-word-props?
|
||||||
|
{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed word properties from words in the dictionary."
|
||||||
|
$nl
|
||||||
|
"On by default. Disable this if the heuristics strip out required word properties." } ;
|
||||||
|
|
||||||
|
HELP: strip-word-names?
|
||||||
|
{ $description "Deploy flag. If set, the deploy tool strips word names from words in the dictionary."
|
||||||
|
$nl
|
||||||
|
"On by default. Disable this if your program calls " { $link word-name } "." } ;
|
||||||
|
|
||||||
|
HELP: strip-dictionary?
|
||||||
|
{ $description "Deploy flag. If set, the deploy tool strips unused words."
|
||||||
|
$nl
|
||||||
|
"On by default. Disable this if your program calls " { $link lookup } " to look up words by name, or needs to parse code at run-time." } ;
|
||||||
|
|
||||||
|
HELP: strip-debugger?
|
||||||
|
{ $description "Deploy flag. If set, the deploy tool strips the verbose error reporting facility; any errors thrown by the program will start the low-level debugger in the VM."
|
||||||
|
$nl
|
||||||
|
"On by default. Disable this if you need to debug a problem which only occurs when your program is running deployed." } ;
|
||||||
|
|
||||||
|
HELP: strip-prettyprint?
|
||||||
|
{ $description "Deploy flag. If set, the deploy tool strips variables used by the prettyprinter."
|
||||||
|
$nl
|
||||||
|
"On by default. Disable this if your program uses the prettyprinter." } ;
|
||||||
|
|
||||||
|
HELP: strip-c-types?
|
||||||
|
{ $description "Deploy flag. If set, the deploy tool strips out the " { $link c-types } " table."
|
||||||
|
$nl
|
||||||
|
"On by default. Disable this if your program calls " { $link c-type } ", " { $link heap-size } ", " { $link <c-object> } ", " { $link <c-array> } ", " { $link malloc-object } ", or " { $link malloc-array } " with a C type name which is not a literal pushed directly at the call site. In this situation, the compiler is unable to fold away the C type lookup, and thus must use the global table at runtime." } ;
|
||||||
|
|
||||||
|
HELP: deploy-math?
|
||||||
|
{ $description "Deploy flag. If set, the deployed image will contain the full number tower."
|
||||||
|
$nl
|
||||||
|
"On by default. Most programs require the number tower, in particular, any program deployed with " { $link deploy-compiled? } " set." } ;
|
||||||
|
|
||||||
|
HELP: deploy-compiled?
|
||||||
|
{ $description "Deploy flag. If set, words in the deployed image will be compiled when possible."
|
||||||
|
$nl
|
||||||
|
"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
|
||||||
|
|
||||||
|
HELP: deploy-ui?
|
||||||
|
{ $description "Deploy flag. If set, the Factor UI will be included in the deployed image."
|
||||||
|
$nl
|
||||||
|
"Off by default. Programs wishing to use the UI must be deployed with this flag on." } ;
|
||||||
|
|
||||||
|
HELP: deploy-io?
|
||||||
|
{ $description "Deploy flag. If set, support for non-blocking I/O and networking will be included in the deployed image."
|
||||||
|
$nl
|
||||||
|
"Off by default. Programs wishing to use non-blocking I/O or networking must be deployed with this flag on." } ;
|
||||||
|
|
||||||
|
HELP: default-config
|
||||||
|
{ $values { "assoc" assoc } }
|
||||||
|
{ $description "Outputs the default deployment configuration." } ;
|
||||||
|
|
||||||
|
HELP: deploy-config
|
||||||
|
{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } }
|
||||||
|
{ $description "Loads a vocabulary's deployment configuration from the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If the file does not exist, the " { $link default-config } " is output." } ;
|
||||||
|
|
||||||
|
HELP: set-deploy-config
|
||||||
|
{ $values { "assoc" assoc } { "vocab" "a vocabulary specifier" } }
|
||||||
|
{ $description "Stores a vocabulary's deployment configuration to the " { $snippet "deploy.factor" } " file in the vocabulary's directory." } ;
|
||||||
|
|
||||||
|
HELP: set-deploy-flag
|
||||||
|
{ $values { "value" object } { "key" object } { "vocab" "a vocabulary specifier" } }
|
||||||
|
{ $description "Modifies an entry in a vocabulary's deployment configuration on disk." } ;
|
||||||
|
|
@ -0,0 +1,53 @@
|
||||||
|
! Copyright (C) 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: vocabs.loader io.files io kernel sequences assocs
|
||||||
|
splitting parser prettyprint ;
|
||||||
|
IN: tools.deploy.config
|
||||||
|
|
||||||
|
SYMBOL: strip-globals?
|
||||||
|
SYMBOL: strip-word-props?
|
||||||
|
SYMBOL: strip-word-names?
|
||||||
|
SYMBOL: strip-dictionary?
|
||||||
|
SYMBOL: strip-debugger?
|
||||||
|
SYMBOL: strip-prettyprint?
|
||||||
|
SYMBOL: strip-c-types?
|
||||||
|
|
||||||
|
SYMBOL: deploy-math?
|
||||||
|
SYMBOL: deploy-compiled?
|
||||||
|
SYMBOL: deploy-io?
|
||||||
|
SYMBOL: deploy-ui?
|
||||||
|
|
||||||
|
SYMBOL: deploy-vm
|
||||||
|
SYMBOL: deploy-image
|
||||||
|
|
||||||
|
: default-config ( -- assoc )
|
||||||
|
V{
|
||||||
|
{ strip-prettyprint? t }
|
||||||
|
{ strip-globals? t }
|
||||||
|
{ strip-word-props? t }
|
||||||
|
{ strip-word-names? t }
|
||||||
|
{ strip-dictionary? t }
|
||||||
|
{ strip-debugger? t }
|
||||||
|
{ strip-c-types? t }
|
||||||
|
{ deploy-math? t }
|
||||||
|
{ deploy-compiled? t }
|
||||||
|
{ deploy-io? f }
|
||||||
|
{ deploy-ui? f }
|
||||||
|
! default value for deploy.app
|
||||||
|
{ "stop-after-last-window?" t }
|
||||||
|
} clone ;
|
||||||
|
|
||||||
|
: deploy-config-path ( vocab -- string )
|
||||||
|
vocab-dir "deploy.factor" path+ ;
|
||||||
|
|
||||||
|
: deploy-config ( vocab -- assoc )
|
||||||
|
default-config swap
|
||||||
|
dup deploy-config-path vocab-file-contents
|
||||||
|
parse-fresh dup empty? [ drop ] [ first union ] if ;
|
||||||
|
|
||||||
|
: set-deploy-config ( assoc vocab -- )
|
||||||
|
>r unparse-use string-lines r>
|
||||||
|
dup deploy-config-path set-vocab-file-contents ;
|
||||||
|
|
||||||
|
: set-deploy-flag ( value key vocab -- )
|
||||||
|
[ deploy-config [ set-at ] keep ] keep set-deploy-config ;
|
||||||
|
|
@ -2,30 +2,6 @@ USING: help.markup help.syntax words alien.c-types assocs
|
||||||
kernel ;
|
kernel ;
|
||||||
IN: tools.deploy
|
IN: tools.deploy
|
||||||
|
|
||||||
ARTICLE: "deploy-config" "Deployment configuration"
|
|
||||||
"The deployment configuration is a key/value mapping stored in the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If this file does not exist, the default deployment configuration is used:"
|
|
||||||
{ $subsection default-config }
|
|
||||||
"The deployment configuration can be read and written with a pair of words:"
|
|
||||||
{ $subsection deploy-config }
|
|
||||||
{ $subsection set-deploy-config }
|
|
||||||
"A utility word is provided to load the configuration, change a flag, and store it back to disk:"
|
|
||||||
{ $subsection set-deploy-flag } ;
|
|
||||||
|
|
||||||
ARTICLE: "deploy-flags" "Deployment flags"
|
|
||||||
"There are two types of flags. The first set controls the major subsystems which are to be included in the deployment image:"
|
|
||||||
{ $subsection deploy-math? }
|
|
||||||
{ $subsection deploy-compiled? }
|
|
||||||
{ $subsection deploy-io? }
|
|
||||||
{ $subsection deploy-ui? }
|
|
||||||
"The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:"
|
|
||||||
{ $subsection strip-globals? }
|
|
||||||
{ $subsection strip-word-props? }
|
|
||||||
{ $subsection strip-word-names? }
|
|
||||||
{ $subsection strip-dictionary? }
|
|
||||||
{ $subsection strip-debugger? }
|
|
||||||
{ $subsection strip-prettyprint? }
|
|
||||||
{ $subsection strip-c-types? } ;
|
|
||||||
|
|
||||||
ARTICLE: "tools.deploy" "Stand-alone image deployment"
|
ARTICLE: "tools.deploy" "Stand-alone image deployment"
|
||||||
"The stand-alone image deployment tool takes a vocabulary and generates an image, which when passed to the VM, runs the vocabulary's " { $link POSTPONE: MAIN: } " hook."
|
"The stand-alone image deployment tool takes a vocabulary and generates an image, which when passed to the VM, runs the vocabulary's " { $link POSTPONE: MAIN: } " hook."
|
||||||
$nl
|
$nl
|
||||||
|
|
@ -33,85 +9,12 @@ $nl
|
||||||
{ $code "\"hello-world\" deploy" }
|
{ $code "\"hello-world\" deploy" }
|
||||||
"This generates an image file named " { $snippet "hello-world.image" } ". Now we can start this image from the operating system's command line (see " { $link "runtime-cli-args" } "):"
|
"This generates an image file named " { $snippet "hello-world.image" } ". Now we can start this image from the operating system's command line (see " { $link "runtime-cli-args" } "):"
|
||||||
{ $code "./factor -i=hello-world.image" "Hello world" }
|
{ $code "./factor -i=hello-world.image" "Hello world" }
|
||||||
"In order to deploy an application as a stand-alone image, the application's vocabulary must first be given a " { $link POSTPONE: MAIN: } " hook. Then, a " { $emphasis "deployment configuration" } " must be created."
|
|
||||||
{ $subsection "deploy-config" }
|
|
||||||
{ $subsection "deploy-flags" }
|
|
||||||
"Once the necessary deployment flags have been set, a deployment image can be generated:"
|
"Once the necessary deployment flags have been set, a deployment image can be generated:"
|
||||||
{ $subsection deploy } ;
|
{ $subsection deploy } ;
|
||||||
|
|
||||||
ABOUT: "tools.deploy"
|
ABOUT: "tools.deploy"
|
||||||
|
|
||||||
HELP: strip-globals?
|
|
||||||
{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed variables from the global namespace."
|
|
||||||
$nl
|
|
||||||
"On by default. Disable this if the heuristics strip out required variables." } ;
|
|
||||||
|
|
||||||
HELP: strip-word-props?
|
|
||||||
{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed word properties from words in the dictionary."
|
|
||||||
$nl
|
|
||||||
"On by default. Disable this if the heuristics strip out required word properties." } ;
|
|
||||||
|
|
||||||
HELP: strip-word-names?
|
|
||||||
{ $description "Deploy flag. If set, the deploy tool strips word names from words in the dictionary."
|
|
||||||
$nl
|
|
||||||
"On by default. Disable this if your program calls " { $link word-name } "." } ;
|
|
||||||
|
|
||||||
HELP: strip-dictionary?
|
|
||||||
{ $description "Deploy flag. If set, the deploy tool strips unused words."
|
|
||||||
$nl
|
|
||||||
"On by default. Disable this if your program calls " { $link lookup } " to look up words by name, or needs to parse code at run-time." } ;
|
|
||||||
|
|
||||||
HELP: strip-debugger?
|
|
||||||
{ $description "Deploy flag. If set, the deploy tool strips the verbose error reporting facility; any errors thrown by the program will start the low-level debugger in the VM."
|
|
||||||
$nl
|
|
||||||
"On by default. Disable this if you need to debug a problem which only occurs when your program is running deployed." } ;
|
|
||||||
|
|
||||||
HELP: strip-prettyprint?
|
|
||||||
{ $description "Deploy flag. If set, the deploy tool strips variables used by the prettyprinter."
|
|
||||||
$nl
|
|
||||||
"On by default. Disable this if your program uses the prettyprinter." } ;
|
|
||||||
|
|
||||||
HELP: strip-c-types?
|
|
||||||
{ $description "Deploy flag. If set, the deploy tool strips out the " { $link c-types } " table."
|
|
||||||
$nl
|
|
||||||
"On by default. Disable this if your program calls " { $link c-type } ", " { $link heap-size } ", " { $link <c-object> } ", " { $link <c-array> } ", " { $link malloc-object } ", or " { $link malloc-array } " with a C type name which is not a literal pushed directly at the call site. In this situation, the compiler is unable to fold away the C type lookup, and thus must use the global table at runtime." } ;
|
|
||||||
|
|
||||||
HELP: deploy-math?
|
|
||||||
{ $description "Deploy flag. If set, the deployed image will contain the full number tower."
|
|
||||||
$nl
|
|
||||||
"On by default. Most programs require the number tower, in particular, any program deployed with " { $link deploy-compiled? } " set." } ;
|
|
||||||
|
|
||||||
HELP: deploy-compiled?
|
|
||||||
{ $description "Deploy flag. If set, words in the deployed image will be compiled when possible."
|
|
||||||
$nl
|
|
||||||
"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
|
|
||||||
|
|
||||||
HELP: deploy-ui?
|
|
||||||
{ $description "Deploy flag. If set, the Factor UI will be included in the deployed image."
|
|
||||||
$nl
|
|
||||||
"Off by default. Programs wishing to use the UI must be deployed with this flag on." } ;
|
|
||||||
|
|
||||||
HELP: deploy-io?
|
|
||||||
{ $description "Deploy flag. If set, support for non-blocking I/O and networking will be included in the deployed image."
|
|
||||||
$nl
|
|
||||||
"Off by default. Programs wishing to use non-blocking I/O or networking must be deployed with this flag on." } ;
|
|
||||||
|
|
||||||
HELP: default-config
|
|
||||||
{ $values { "assoc" assoc } }
|
|
||||||
{ $description "Outputs the default deployment configuration." } ;
|
|
||||||
|
|
||||||
HELP: deploy-config
|
|
||||||
{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } }
|
|
||||||
{ $description "Loads a vocabulary's deployment configuration from the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If the file does not exist, the " { $link default-config } " is output." } ;
|
|
||||||
|
|
||||||
HELP: set-deploy-config
|
|
||||||
{ $values { "assoc" assoc } { "vocab" "a vocabulary specifier" } }
|
|
||||||
{ $description "Stores a vocabulary's deployment configuration to the " { $snippet "deploy.factor" } " file in the vocabulary's directory." } ;
|
|
||||||
|
|
||||||
HELP: set-deploy-flag
|
|
||||||
{ $values { "value" object } { "key" object } { "vocab" "a vocabulary specifier" } }
|
|
||||||
{ $description "Modifies an entry in a vocabulary's deployment configuration on disk." } ;
|
|
||||||
|
|
||||||
HELP: deploy*
|
HELP: deploy*
|
||||||
{ $values { "vm" "a pathname string" } { "image" "a pathname string" } { "vocab" "a vocabulary specifier" } { "config" assoc } }
|
{ $values { "vm" "a pathname string" } { "image" "a pathname string" } { "vocab" "a vocabulary specifier" } { "config" assoc } }
|
||||||
{ $description "Deploys " { $snippet "vocab" } ", which must have a " { $link POSTPONE: MAIN: } " hook, using the specified VM and configuration. The deployed image is saved as " { $snippet "image" } "." }
|
{ $description "Deploys " { $snippet "vocab" } ", which must have a " { $link POSTPONE: MAIN: } " hook, using the specified VM and configuration. The deployed image is saved as " { $snippet "image" } "." }
|
||||||
|
|
|
||||||
|
|
@ -5,255 +5,30 @@ assocs kernel vocabs words sequences memory io system arrays
|
||||||
continuations math definitions mirrors splitting parser classes
|
continuations math definitions mirrors splitting parser classes
|
||||||
inspector layouts vocabs.loader prettyprint.config prettyprint
|
inspector layouts vocabs.loader prettyprint.config prettyprint
|
||||||
debugger io.streams.c io.streams.duplex io.files io.backend
|
debugger io.streams.c io.streams.duplex io.files io.backend
|
||||||
quotations io.launcher words.private ;
|
quotations io.launcher words.private tools.deploy.config ;
|
||||||
IN: tools.deploy
|
IN: tools.deploy
|
||||||
|
|
||||||
SYMBOL: strip-globals?
|
|
||||||
SYMBOL: strip-word-props?
|
|
||||||
SYMBOL: strip-word-names?
|
|
||||||
SYMBOL: strip-dictionary?
|
|
||||||
SYMBOL: strip-debugger?
|
|
||||||
SYMBOL: strip-prettyprint?
|
|
||||||
SYMBOL: strip-c-types?
|
|
||||||
|
|
||||||
SYMBOL: deploy-math?
|
|
||||||
SYMBOL: deploy-compiled?
|
|
||||||
SYMBOL: deploy-io?
|
|
||||||
SYMBOL: deploy-ui?
|
|
||||||
|
|
||||||
SYMBOL: deploy-vm
|
|
||||||
SYMBOL: deploy-image
|
|
||||||
|
|
||||||
: default-config ( -- assoc )
|
|
||||||
V{
|
|
||||||
{ strip-prettyprint? t }
|
|
||||||
{ strip-globals? t }
|
|
||||||
{ strip-word-props? t }
|
|
||||||
{ strip-word-names? t }
|
|
||||||
{ strip-dictionary? t }
|
|
||||||
{ strip-debugger? t }
|
|
||||||
{ strip-c-types? t }
|
|
||||||
{ deploy-math? t }
|
|
||||||
{ deploy-compiled? t }
|
|
||||||
{ deploy-io? f }
|
|
||||||
{ deploy-ui? f }
|
|
||||||
! default value for deploy.app
|
|
||||||
{ "stop-after-last-window?" t }
|
|
||||||
} clone ;
|
|
||||||
|
|
||||||
: deploy-config-path ( vocab -- string )
|
|
||||||
vocab-dir "deploy.factor" path+ ;
|
|
||||||
|
|
||||||
: deploy-config ( vocab -- assoc )
|
|
||||||
default-config swap
|
|
||||||
dup deploy-config-path vocab-file-contents
|
|
||||||
parse-fresh dup empty? [ drop ] [ first union ] if ;
|
|
||||||
|
|
||||||
: set-deploy-config ( assoc vocab -- )
|
|
||||||
>r unparse-use string-lines r>
|
|
||||||
dup deploy-config-path set-vocab-file-contents ;
|
|
||||||
|
|
||||||
: set-deploy-flag ( value key vocab -- )
|
|
||||||
[ deploy-config [ set-at ] keep ] keep set-deploy-config ;
|
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: show ( msg -- )
|
|
||||||
#! Use primitives directly so that we can print stuff even
|
|
||||||
#! after most of the image has been stripped away
|
|
||||||
"\r\n" append stdout fwrite stdout fflush ;
|
|
||||||
|
|
||||||
: strip-init-hooks ( -- )
|
|
||||||
"Stripping startup hooks" show
|
|
||||||
"command-line" init-hooks get delete-at ;
|
|
||||||
|
|
||||||
: strip-debugger ( -- )
|
|
||||||
strip-debugger? get [
|
|
||||||
"Stripping debugger" show
|
|
||||||
"resource:extra/tools/deploy/strip-debugger.factor"
|
|
||||||
run-file
|
|
||||||
] when ;
|
|
||||||
|
|
||||||
: strip-cocoa ( -- )
|
|
||||||
"cocoa" vocab [
|
|
||||||
"Stripping unused Cocoa methods" show
|
|
||||||
"resource:extra/tools/deploy/strip-cocoa.factor"
|
|
||||||
run-file
|
|
||||||
] when ;
|
|
||||||
|
|
||||||
: strip-assoc ( retained-keys assoc -- newassoc )
|
|
||||||
swap [ nip member? ] curry assoc-subset ;
|
|
||||||
|
|
||||||
: strip-word-names ( words -- )
|
|
||||||
"Stripping word names" show
|
|
||||||
[ f over set-word-name f swap set-word-vocabulary ] each ;
|
|
||||||
|
|
||||||
: strip-word-defs ( words -- )
|
|
||||||
"Stripping unoptimized definitions from optimized words" show
|
|
||||||
[ compiled? ] subset [ f swap set-word-def ] each ;
|
|
||||||
|
|
||||||
: strip-word-props ( retain-props words -- )
|
|
||||||
"Stripping word properties" show
|
|
||||||
[
|
|
||||||
[ word-props strip-assoc f assoc-like ] keep
|
|
||||||
set-word-props
|
|
||||||
] curry* each ;
|
|
||||||
|
|
||||||
: retained-props ( -- seq )
|
|
||||||
[
|
|
||||||
"class" ,
|
|
||||||
"metaclass" ,
|
|
||||||
"slot-names" ,
|
|
||||||
deploy-ui? get [
|
|
||||||
"gestures" ,
|
|
||||||
"commands" ,
|
|
||||||
{ "+nullary+" "+listener+" "+description+" }
|
|
||||||
[ "ui.commands" lookup , ] each
|
|
||||||
] when
|
|
||||||
] { } make ;
|
|
||||||
|
|
||||||
: strip-words ( props -- )
|
|
||||||
[ word? ] instances
|
|
||||||
strip-word-props? get [ tuck strip-word-props ] [ nip ] if
|
|
||||||
strip-word-names? get [ dup strip-word-names ] when
|
|
||||||
strip-word-defs ;
|
|
||||||
|
|
||||||
USING: bit-arrays byte-arrays io.streams.nested ;
|
|
||||||
|
|
||||||
: strip-classes ( -- )
|
|
||||||
"Stripping classes" show
|
|
||||||
io-backend get [
|
|
||||||
c-reader forget
|
|
||||||
c-writer forget
|
|
||||||
] when
|
|
||||||
{ style-stream mirror enum } [ forget ] each ;
|
|
||||||
|
|
||||||
: strip-environment ( retain-globals -- )
|
|
||||||
"Stripping environment" show
|
|
||||||
strip-globals? get [
|
|
||||||
global strip-assoc 21 setenv
|
|
||||||
] [ drop ] if ;
|
|
||||||
|
|
||||||
: finish-deploy ( final-image -- )
|
|
||||||
"Finishing up" show
|
|
||||||
>r V{ } set-datastack r>
|
|
||||||
V{ } set-retainstack
|
|
||||||
V{ } set-callstack
|
|
||||||
V{ } set-namestack
|
|
||||||
V{ } set-catchstack
|
|
||||||
"Saving final image" show
|
|
||||||
[ save-image-and-exit ] call ;
|
|
||||||
|
|
||||||
SYMBOL: deploy-vocab
|
|
||||||
|
|
||||||
: set-boot-quot* ( word -- )
|
|
||||||
[
|
|
||||||
\ boot ,
|
|
||||||
init-hooks get values concat %
|
|
||||||
,
|
|
||||||
"io.backend" init-hooks get at [ \ flush , ] when
|
|
||||||
] [ ] make "Boot quotation: " write dup . flush
|
|
||||||
set-boot-quot ;
|
|
||||||
|
|
||||||
: retained-globals ( -- seq )
|
|
||||||
[
|
|
||||||
builtins ,
|
|
||||||
io-backend ,
|
|
||||||
|
|
||||||
strip-dictionary? get [
|
|
||||||
{
|
|
||||||
builtins
|
|
||||||
dictionary
|
|
||||||
inspector-hook
|
|
||||||
lexer-factory
|
|
||||||
load-vocab-hook
|
|
||||||
num-tags
|
|
||||||
num-types
|
|
||||||
tag-bits
|
|
||||||
tag-mask
|
|
||||||
tag-numbers
|
|
||||||
typemap
|
|
||||||
vocab-roots
|
|
||||||
} %
|
|
||||||
] unless
|
|
||||||
|
|
||||||
strip-prettyprint? get [
|
|
||||||
{
|
|
||||||
tab-size
|
|
||||||
margin
|
|
||||||
} %
|
|
||||||
] unless
|
|
||||||
|
|
||||||
strip-c-types? get not deploy-ui? get or [
|
|
||||||
"c-types" "alien.c-types" lookup ,
|
|
||||||
] when
|
|
||||||
|
|
||||||
deploy-ui? get [
|
|
||||||
"ui" child-vocabs
|
|
||||||
"cocoa" child-vocabs
|
|
||||||
deploy-vocab get child-vocabs 3append
|
|
||||||
global keys [ word? ] subset
|
|
||||||
swap [ >r word-vocabulary r> member? ] curry
|
|
||||||
subset %
|
|
||||||
] when
|
|
||||||
] { } make dup . ;
|
|
||||||
|
|
||||||
: normalize-strip-flags
|
|
||||||
strip-prettyprint? get [
|
|
||||||
strip-word-names? off
|
|
||||||
] unless
|
|
||||||
strip-dictionary? get [
|
|
||||||
strip-prettyprint? off
|
|
||||||
strip-word-names? off
|
|
||||||
strip-word-props? off
|
|
||||||
] unless ;
|
|
||||||
|
|
||||||
: strip ( -- )
|
|
||||||
normalize-strip-flags
|
|
||||||
strip-cocoa
|
|
||||||
strip-debugger
|
|
||||||
strip-init-hooks
|
|
||||||
deploy-vocab get vocab-main set-boot-quot*
|
|
||||||
retained-props >r
|
|
||||||
retained-globals strip-environment
|
|
||||||
r> strip-words ;
|
|
||||||
|
|
||||||
: (deploy) ( final-image vocab config -- )
|
|
||||||
#! Does the actual work of a deployment in the slave
|
|
||||||
#! stage2 image
|
|
||||||
[
|
|
||||||
[
|
|
||||||
deploy-vocab set
|
|
||||||
parse-hook get >r
|
|
||||||
parse-hook off
|
|
||||||
deploy-vocab get require
|
|
||||||
r> call
|
|
||||||
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) ;
|
|
||||||
|
|
||||||
: (copy-lines) ( stream -- stream )
|
: (copy-lines) ( stream -- stream )
|
||||||
dup stream-readln [ print flush (copy-lines) ] when* ;
|
dup stream-readln [ print flush (copy-lines) ] when* ;
|
||||||
|
|
||||||
: copy-lines ( stream -- )
|
: copy-lines ( stream -- )
|
||||||
[ (copy-lines) ] [ stream-close ] [ ] cleanup ;
|
[ (copy-lines) ] [ stream-close ] [ ] cleanup ;
|
||||||
|
|
||||||
|
: boot-image-name ( -- string )
|
||||||
|
cpu dup "ppc" = [ os "-" rot 3append ] when ;
|
||||||
|
|
||||||
: stage2 ( vm flags -- )
|
: stage2 ( vm flags -- )
|
||||||
[
|
[
|
||||||
"\"" % swap % "\" -i=boot." % cpu % ".image" %
|
"\"" % swap % "\" -i=boot." %
|
||||||
|
boot-image-name
|
||||||
|
% ".image" %
|
||||||
[ " " % % ] each
|
[ " " % % ] each
|
||||||
] "" make
|
] "" make
|
||||||
dup print <process-stream> copy-lines ;
|
dup print <process-stream>
|
||||||
|
dup duplex-stream-out stream-close
|
||||||
|
copy-lines ;
|
||||||
|
|
||||||
: profile-string ( config -- string )
|
: profile-string ( config -- string )
|
||||||
{
|
{
|
||||||
|
|
@ -283,5 +58,3 @@ PRIVATE>
|
||||||
|
|
||||||
: deploy ( vocab -- )
|
: deploy ( vocab -- )
|
||||||
vm over ".image" append rot dup deploy-config deploy* ;
|
vm over ".image" append rot dup deploy-config deploy* ;
|
||||||
|
|
||||||
MAIN: do-deploy
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,194 @@
|
||||||
|
! Copyright (C) 2007 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: namespaces continuations.private kernel.private init
|
||||||
|
assocs kernel vocabs words sequences memory io system arrays
|
||||||
|
continuations math definitions mirrors splitting parser classes
|
||||||
|
inspector layouts vocabs.loader prettyprint.config prettyprint
|
||||||
|
debugger io.streams.c io.streams.duplex io.files io.backend
|
||||||
|
quotations words.private tools.deploy.config ;
|
||||||
|
IN: tools.deploy.shaker
|
||||||
|
|
||||||
|
: show ( msg -- )
|
||||||
|
#! Use primitives directly so that we can print stuff even
|
||||||
|
#! after most of the image has been stripped away
|
||||||
|
"\r\n" append stdout fwrite stdout fflush ;
|
||||||
|
|
||||||
|
: strip-init-hooks ( -- )
|
||||||
|
"Stripping startup hooks" show
|
||||||
|
"command-line" init-hooks get delete-at ;
|
||||||
|
|
||||||
|
: strip-debugger ( -- )
|
||||||
|
strip-debugger? get [
|
||||||
|
"Stripping debugger" show
|
||||||
|
"resource:extra/tools/deploy/strip-debugger.factor"
|
||||||
|
run-file
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: strip-cocoa ( -- )
|
||||||
|
"cocoa" vocab [
|
||||||
|
"Stripping unused Cocoa methods" show
|
||||||
|
"resource:extra/tools/deploy/strip-cocoa.factor"
|
||||||
|
run-file
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: strip-assoc ( retained-keys assoc -- newassoc )
|
||||||
|
swap [ nip member? ] curry assoc-subset ;
|
||||||
|
|
||||||
|
: strip-word-names ( words -- )
|
||||||
|
"Stripping word names" show
|
||||||
|
[ f over set-word-name f swap set-word-vocabulary ] each ;
|
||||||
|
|
||||||
|
: strip-word-defs ( words -- )
|
||||||
|
"Stripping unoptimized definitions from optimized words" show
|
||||||
|
[ compiled? ] subset [ [ ] swap set-word-def ] each ;
|
||||||
|
|
||||||
|
: strip-word-props ( retain-props words -- )
|
||||||
|
"Stripping word properties" show
|
||||||
|
[
|
||||||
|
[ word-props strip-assoc f assoc-like ] keep
|
||||||
|
set-word-props
|
||||||
|
] curry* each ;
|
||||||
|
|
||||||
|
: retained-props ( -- seq )
|
||||||
|
[
|
||||||
|
"class" ,
|
||||||
|
"metaclass" ,
|
||||||
|
"slot-names" ,
|
||||||
|
deploy-ui? get [
|
||||||
|
"gestures" ,
|
||||||
|
"commands" ,
|
||||||
|
{ "+nullary+" "+listener+" "+description+" }
|
||||||
|
[ "ui.commands" lookup , ] each
|
||||||
|
] when
|
||||||
|
] { } make ;
|
||||||
|
|
||||||
|
: strip-words ( props -- )
|
||||||
|
[ word? ] instances
|
||||||
|
strip-word-props? get [ tuck strip-word-props ] [ nip ] if
|
||||||
|
strip-word-names? get [ dup strip-word-names ] when
|
||||||
|
strip-word-defs ;
|
||||||
|
|
||||||
|
USING: bit-arrays byte-arrays io.streams.nested ;
|
||||||
|
|
||||||
|
: strip-classes ( -- )
|
||||||
|
"Stripping classes" show
|
||||||
|
io-backend get [
|
||||||
|
c-reader forget
|
||||||
|
c-writer forget
|
||||||
|
] when
|
||||||
|
{ style-stream mirror enum } [ forget ] each ;
|
||||||
|
|
||||||
|
: strip-environment ( retain-globals -- )
|
||||||
|
"Stripping environment" show
|
||||||
|
strip-globals? get [
|
||||||
|
global strip-assoc 21 setenv
|
||||||
|
] [ drop ] if ;
|
||||||
|
|
||||||
|
: 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 %
|
||||||
|
,
|
||||||
|
"io.backend" init-hooks get at [ \ flush , ] when
|
||||||
|
] [ ] make "Boot quotation: " write dup . flush
|
||||||
|
set-boot-quot ;
|
||||||
|
|
||||||
|
: retained-globals ( -- seq )
|
||||||
|
[
|
||||||
|
builtins ,
|
||||||
|
io-backend ,
|
||||||
|
|
||||||
|
strip-dictionary? get [
|
||||||
|
{
|
||||||
|
builtins
|
||||||
|
dictionary
|
||||||
|
inspector-hook
|
||||||
|
lexer-factory
|
||||||
|
load-vocab-hook
|
||||||
|
num-tags
|
||||||
|
num-types
|
||||||
|
tag-bits
|
||||||
|
tag-mask
|
||||||
|
tag-numbers
|
||||||
|
typemap
|
||||||
|
vocab-roots
|
||||||
|
} %
|
||||||
|
] unless
|
||||||
|
|
||||||
|
strip-prettyprint? get [
|
||||||
|
{
|
||||||
|
tab-size
|
||||||
|
margin
|
||||||
|
} %
|
||||||
|
] unless
|
||||||
|
|
||||||
|
strip-c-types? get not deploy-ui? get or [
|
||||||
|
"c-types" "alien.c-types" lookup ,
|
||||||
|
] when
|
||||||
|
|
||||||
|
deploy-ui? get [
|
||||||
|
"ui" child-vocabs
|
||||||
|
"cocoa" child-vocabs
|
||||||
|
deploy-vocab get child-vocabs 3append
|
||||||
|
global keys [ word? ] subset
|
||||||
|
swap [ >r word-vocabulary r> member? ] curry
|
||||||
|
subset %
|
||||||
|
] when
|
||||||
|
] { } make dup . ;
|
||||||
|
|
||||||
|
: normalize-strip-flags
|
||||||
|
strip-prettyprint? get [
|
||||||
|
strip-word-names? off
|
||||||
|
] unless
|
||||||
|
strip-dictionary? get [
|
||||||
|
strip-prettyprint? off
|
||||||
|
strip-word-names? off
|
||||||
|
strip-word-props? off
|
||||||
|
] unless ;
|
||||||
|
|
||||||
|
: strip ( -- )
|
||||||
|
normalize-strip-flags
|
||||||
|
strip-cocoa
|
||||||
|
strip-debugger
|
||||||
|
strip-init-hooks
|
||||||
|
deploy-vocab get vocab-main set-boot-quot*
|
||||||
|
retained-props >r
|
||||||
|
retained-globals strip-environment
|
||||||
|
r> strip-words ;
|
||||||
|
|
||||||
|
: (deploy) ( final-image vocab config -- )
|
||||||
|
#! Does the actual work of a deployment in the slave
|
||||||
|
#! stage2 image
|
||||||
|
[
|
||||||
|
[
|
||||||
|
deploy-vocab set
|
||||||
|
parse-hook get >r
|
||||||
|
parse-hook off
|
||||||
|
deploy-vocab get require
|
||||||
|
r> [ call ] when*
|
||||||
|
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
|
||||||
Loading…
Reference in New Issue