Deploy tool: if debugger is not stripped out, actually use it to report errors; print an error if vocab has no MAIN: word

db4
Slava Pestov 2009-02-16 19:00:09 -06:00
parent 1f273a852a
commit 20053c7f5c
4 changed files with 45 additions and 23 deletions

View File

@ -70,7 +70,7 @@ M: string error. print ;
"Type :help for debugging help." print flush ; "Type :help for debugging help." print flush ;
: try ( quot -- ) : try ( quot -- )
[ print-error-and-restarts ] recover ; [ print-error-and-restarts ] recover ; inline
: expired-error. ( obj -- ) : expired-error. ( obj -- )
"Object did not survive image save/load: " write third . ; "Object did not survive image save/load: " write third . ;

View File

@ -58,25 +58,17 @@ DEFER: ?make-staging-image
: staging-command-line ( profile -- flags ) : staging-command-line ( profile -- flags )
[ [
"-staging" , "-staging" ,
dup empty? [ dup empty? [
"-i=" my-boot-image-name append , "-i=" my-boot-image-name append ,
] [ ] [
dup but-last ?make-staging-image dup but-last ?make-staging-image
"-resource-path=" "" resource-path append , "-resource-path=" "" resource-path append ,
"-i=" over but-last staging-image-name append , "-i=" over but-last staging-image-name append ,
"-run=tools.deploy.restage" , "-run=tools.deploy.restage" ,
] if ] if
"-output-image=" over staging-image-name append , "-output-image=" over staging-image-name append ,
"-include=" swap " " join append , "-include=" swap " " join append ,
strip-word-names? [ "-no-stack-traces" , ] when strip-word-names? [ "-no-stack-traces" , ] when
"-no-user-init" , "-no-user-init" ,
] { } make ; ] { } make ;
@ -101,16 +93,11 @@ DEFER: ?make-staging-image
[ [
"-i=" bootstrap-profile staging-image-name append , "-i=" bootstrap-profile staging-image-name append ,
"-resource-path=" "" resource-path append , "-resource-path=" "" resource-path append ,
"-run=tools.deploy.shaker" , "-run=tools.deploy.shaker" ,
[ "-deploy-vocab=" prepend , ] [ "-deploy-vocab=" prepend , ]
[ make-deploy-config "-deploy-config=" prepend , ] bi [ make-deploy-config "-deploy-config=" prepend , ] bi
"-output-image=" prepend , "-output-image=" prepend ,
strip-word-names? [ "-no-stack-traces" , ] when strip-word-names? [ "-no-stack-traces" , ] when
] { } make ] { } make
] bind ; ] bind ;

View File

@ -104,3 +104,8 @@ M: quit-responder call-responder*
"tools.deploy.test.10" shake-and-bake "tools.deploy.test.10" shake-and-bake
run-temp-image run-temp-image
] unit-test ] unit-test
[ ] [
"tools.deploy.test.11" shake-and-bake
run-temp-image
] unit-test

View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors io.backend io.streams.c init fry USING: accessors io.backend io.streams.c init fry
namespaces make assocs kernel parser lexer strings.parser vocabs namespaces make assocs kernel parser lexer strings.parser vocabs
@ -232,7 +232,6 @@ IN: tools.deploy.shaker
"tools" "tools"
"io.launcher" "io.launcher"
"random" "random"
"compiler"
"stack-checker" "stack-checker"
"bootstrap" "bootstrap"
"listener" "listener"
@ -241,7 +240,7 @@ IN: tools.deploy.shaker
strip-dictionary? [ strip-dictionary? [
"libraries" "alien" lookup , "libraries" "alien" lookup ,
{ } { "cpu" } strip-vocab-globals % { } { "cpu" "compiler" } strip-vocab-globals %
{ {
gensym gensym
@ -359,12 +358,26 @@ IN: tools.deploy.shaker
SYMBOL: deploy-vocab SYMBOL: deploy-vocab
: set-boot-quot* ( word -- ) : [:c] ( -- word ) ":c" "debugger" lookup ;
: [print-error] ( -- word ) "print-error" "debugger" lookup ;
: deploy-boot-quot ( word -- )
[ [
\ boot , [ boot ] %
init-hooks get values concat % init-hooks get values concat %
, strip-debugger? [ , ] [
strip-io? [ \ flush , ] unless ! Don't reference try directly
[:c]
[print-error]
'[
[ _ execute ] [
_ execute nl
_ execute
] recover
] %
] if
strip-io? [ [ flush ] % ] unless
[ 0 exit ] % [ 0 exit ] %
] [ ] make ] [ ] make
set-boot-quot ; set-boot-quot ;
@ -392,7 +405,7 @@ SYMBOL: deploy-vocab
strip-init-hooks strip-init-hooks
strip-c-io strip-c-io
f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
deploy-vocab get vocab-main set-boot-quot* deploy-vocab get vocab-main deploy-boot-quot
stripped-word-props stripped-word-props
stripped-globals strip-globals stripped-globals strip-globals
compress-byte-arrays compress-byte-arrays
@ -401,16 +414,33 @@ SYMBOL: deploy-vocab
compress-wrappers compress-wrappers
strip-words ; strip-words ;
: deploy-error-handler ( quot -- )
[
strip-debugger?
[ error-continuation get call>> callstack>array die ]
! Don't reference these words literally, if we're stripping the
! debugger out we don't want to load the prettyprinter at all
[ [:c] nl [print-error] ] if
1 exit
] recover ; inline
: (deploy) ( final-image vocab config -- ) : (deploy) ( final-image vocab config -- )
#! Does the actual work of a deployment in the slave #! Does the actual work of a deployment in the slave
#! stage2 image #! stage2 image
[ [
[ [
strip-debugger? [
"debugger" require
"inspector" require
] unless
deploy-vocab set deploy-vocab set
deploy-vocab get require deploy-vocab get require
deploy-vocab get vocab-main [
"Vocabulary has no MAIN: word." print flush 1 exit
] unless
strip strip
finish-deploy finish-deploy
] [ error-continuation get call>> callstack>array die 1 exit ] recover ] deploy-error-handler
] bind ; ] bind ;
: do-deploy ( -- ) : do-deploy ( -- )