builder: another refactoring
Eduardo Cavazos
parent
83f1bc5d8c
commit
336ad674d7
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
USING: kernel parser io io.files io.launcher io.sockets hashtables math threads
|
||||
system continuations namespaces sequences splitting math.parser
|
||||
arrays system continuations namespaces sequences splitting math.parser
|
||||
prettyprint tools.time calendar bake vars http.client
|
||||
combinators bootstrap.image bootstrap.image.download
|
||||
combinators.cleave ;
|
||||
|
|
@ -11,10 +11,10 @@ IN: builder
|
|||
|
||||
: runtime ( quot -- time ) benchmark nip ;
|
||||
|
||||
: log-runtime ( quot file -- )
|
||||
>r runtime r> <file-writer> [ . ] with-stream ;
|
||||
! : log-runtime ( quot file -- )
|
||||
! >r runtime r> <file-writer> [ . ] with-stream ;
|
||||
|
||||
: log-object ( object file -- ) <file-writer> [ . ] with-stream ;
|
||||
! : log-object ( object file -- ) <file-writer> [ . ] with-stream ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -48,16 +48,16 @@ SYMBOL: builder-recipients
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: run-or-notify ( desc message -- )
|
||||
[ [ try-process ] curry ]
|
||||
[ [ email-string throw ] curry ]
|
||||
bi*
|
||||
recover ;
|
||||
! : run-or-notify ( desc message -- )
|
||||
! [ [ try-process ] curry ]
|
||||
! [ [ email-string throw ] curry ]
|
||||
! bi*
|
||||
! recover ;
|
||||
|
||||
: run-or-send-file ( desc message file -- )
|
||||
>r >r [ try-process ] curry
|
||||
r> r> [ email-file throw ] 2curry
|
||||
recover ;
|
||||
! : run-or-send-file ( desc message file -- )
|
||||
! >r >r [ try-process ] curry
|
||||
! r> r> [ email-file throw ] 2curry
|
||||
! recover ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -98,7 +98,9 @@ VAR: stamp
|
|||
: git-id ( -- id )
|
||||
{ "git" "show" } <process-stream> [ readln ] with-stream " " split second ;
|
||||
|
||||
: record-git-id ( -- ) git-id "../git-id" log-object ;
|
||||
! : record-git-id ( -- ) git-id "../git-id" log-object ;
|
||||
|
||||
: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-out ;
|
||||
|
||||
: make-clean ( -- desc ) { "make" "clean" } ;
|
||||
|
||||
|
|
@ -110,12 +112,12 @@ VAR: stamp
|
|||
}
|
||||
>hashtable ;
|
||||
|
||||
: retrieve-boot-image ( -- )
|
||||
[ my-arch download-image ]
|
||||
[ ]
|
||||
[ "builder: image download" email-string ]
|
||||
cleanup
|
||||
flush ;
|
||||
! : retrieve-boot-image ( -- )
|
||||
! [ my-arch download-image ]
|
||||
! [ ]
|
||||
! [ "builder: image download" email-string ]
|
||||
! cleanup
|
||||
! flush ;
|
||||
|
||||
: bootstrap ( -- desc )
|
||||
`{
|
||||
|
|
@ -165,27 +167,27 @@ SYMBOL: build-status
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: report
|
||||
! SYMBOL: report
|
||||
|
||||
: >>>report ( quot -- ) report get swap with-stream* ;
|
||||
! : >>>report ( quot -- ) report get swap with-stream* ;
|
||||
|
||||
: file>>>report ( file -- ) [ <file-reader> contents write ] curry >>>report ;
|
||||
! : file>>>report ( file -- ) [ <file-reader> contents write ] curry >>>report ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: run-or-report ( desc quot -- )
|
||||
[ [ try-process ] curry ]
|
||||
[ [ >>>report throw ] curry ]
|
||||
bi*
|
||||
recover ;
|
||||
! : run-or-report ( desc quot -- )
|
||||
! [ [ try-process ] curry ]
|
||||
! [ [ >>>report throw ] curry ]
|
||||
! bi*
|
||||
! recover ;
|
||||
|
||||
: run-or-report-file ( desc quot file -- )
|
||||
[ [ try-process ] curry ]
|
||||
[ [ >>>report ] curry ]
|
||||
[ [ file>>>report throw ] curry ]
|
||||
tri*
|
||||
compose
|
||||
recover ;
|
||||
! : run-or-report-file ( desc quot file -- )
|
||||
! [ [ try-process ] curry ]
|
||||
! [ [ >>>report ] curry ]
|
||||
! [ [ file>>>report throw ] curry ]
|
||||
! tri*
|
||||
! compose
|
||||
! recover ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -194,80 +196,137 @@ SYMBOL: report
|
|||
! : bootstrap-minutes ( -- )
|
||||
! "../bootstrap-time" <file-reader> contents eval ms>minutes unparse ;
|
||||
|
||||
: min-and-sec ( milliseconds -- str )
|
||||
1000 /i 60 /mod swap
|
||||
`{ ,[ number>string ] " minutes and " ,[ number>string ] " seconds" }
|
||||
concat ;
|
||||
! : min-and-sec ( milliseconds -- str )
|
||||
! 1000 /i 60 /mod swap
|
||||
! `{ ,[ number>string ] " minutes and " ,[ number>string ] " seconds" }
|
||||
! concat ;
|
||||
|
||||
! : boot-time ( -- string ) "../bootstrap-time" eval-file min-and-sec ;
|
||||
! : load-time ( -- string ) "../load-everything-time" eval-file min-and-sec ;
|
||||
! : test-time ( -- string ) "../test-all-time" eval-file min-and-sec ;
|
||||
|
||||
: milli-seconds>time ( n -- string )
|
||||
1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
|
||||
|
||||
: eval-file ( file -- obj ) <file-reader> contents eval ;
|
||||
|
||||
: boot-time ( -- string ) "../bootstrap-time" eval-file min-and-sec ;
|
||||
: load-time ( -- string ) "../load-everything-time" eval-file min-and-sec ;
|
||||
: test-time ( -- string ) "../test-all-time" eval-file min-and-sec ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! : (build) ( -- )
|
||||
|
||||
! enter-build-dir
|
||||
|
||||
! "report" <file-writer> report set
|
||||
|
||||
! [
|
||||
! "Build machine: " write host-name write nl
|
||||
! "Build directory: " write cwd write nl
|
||||
! ] >>>report
|
||||
|
||||
! git-clone [ "Builder fatal error: git clone failed" write nl ] run-or-report
|
||||
|
||||
! "factor" cd
|
||||
|
||||
! record-git-id
|
||||
|
||||
! make-clean run-process drop
|
||||
|
||||
! make-vm
|
||||
! [ "Builder fatal error: vm compile error" write nl ]
|
||||
! "../compile-log"
|
||||
! run-or-report-file
|
||||
|
||||
! [ my-arch download-image ]
|
||||
! [ [ "Builder fatal error: image download" write nl ] >>>report throw ]
|
||||
! recover
|
||||
|
||||
! bootstrap [ "Bootstrap error" write nl ] "../boot-log" run-or-report-file
|
||||
|
||||
! builder-test [ "Builder test error" write nl ] run-or-report
|
||||
|
||||
! [
|
||||
! "Bootstrap time: " write boot-time write nl
|
||||
! "Load all time: " write load-time write nl
|
||||
! "Test all time: " write test-time write nl
|
||||
! ] >>>report
|
||||
|
||||
! "../load-everything-vocabs" exists?
|
||||
! [
|
||||
! [ "Did not pass load-everything: " write nl ] >>>report
|
||||
! "../load-everything-vocabs" file>>>report
|
||||
! ]
|
||||
! when
|
||||
|
||||
! "../test-all-vocabs" exists?
|
||||
! [
|
||||
! [ "Did not pass test-all: " write nl ] >>>report
|
||||
! "../test-all-vocabs" file>>>report
|
||||
! ]
|
||||
! when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: cat ( file -- ) <file-reader> contents print ;
|
||||
|
||||
: run-or-bail ( desc quot -- )
|
||||
[ [ try-process ] curry ]
|
||||
[ [ throw ] curry ]
|
||||
bi*
|
||||
recover ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (build) ( -- )
|
||||
|
||||
enter-build-dir
|
||||
|
||||
"report" <file-writer> report set
|
||||
"report" [
|
||||
|
||||
[
|
||||
"Build machine: " write host-name write nl
|
||||
"Build directory: " write cwd write nl
|
||||
] >>>report
|
||||
"Build machine: " write host-name print
|
||||
"Build directory: " write cwd print
|
||||
|
||||
git-clone [ "Builder fatal error: git clone failed" write nl ] run-or-report
|
||||
git-clone [ "git clone failed" print ] run-or-bail
|
||||
|
||||
"factor" cd
|
||||
"factor" cd
|
||||
|
||||
record-git-id
|
||||
record-git-id
|
||||
|
||||
make-clean run-process drop
|
||||
make-clean run-process drop
|
||||
|
||||
make-vm
|
||||
[ "Builder fatal error: vm compile error" write nl ]
|
||||
"../compile-log"
|
||||
run-or-report-file
|
||||
make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
|
||||
|
||||
[ my-arch download-image ]
|
||||
[ [ "Builder fatal error: image download" write nl ] >>>report throw ]
|
||||
recover
|
||||
[ my-arch download-image ] [ "Image download error" print throw ] recover
|
||||
|
||||
bootstrap [ "Bootstrap error" write nl ] "../boot-log" run-or-report-file
|
||||
bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
|
||||
|
||||
builder-test [ "Builder test error" write nl ] run-or-report
|
||||
[ builder-test try-process ]
|
||||
[ "Builder test error" print throw ]
|
||||
recover
|
||||
|
||||
[
|
||||
"Bootstrap time: " write boot-time write nl
|
||||
"Load all time: " write load-time write nl
|
||||
"Test all time: " write test-time write nl
|
||||
] >>>report
|
||||
"Boot time: " write "../boot-time" eval-file milli-seconds>time print
|
||||
"Load time: " write "../load-time" eval-file milli-seconds>time print
|
||||
"Test time: " write "../test-time" eval-file milli-seconds>time print
|
||||
|
||||
"../load-everything-vocabs" exists?
|
||||
[
|
||||
[ "Did not pass load-everything: " write nl ] >>>report
|
||||
"../load-everything-vocabs" file>>>report
|
||||
]
|
||||
when
|
||||
"Did not pass load-everything: " print "../load-everything-vocabs" cat
|
||||
"Did not pass test-all: " print "../test-all-vocabs" cat
|
||||
|
||||
"../test-all-vocabs" exists?
|
||||
[
|
||||
[ "Did not pass test-all: " write nl ] >>>report
|
||||
"../test-all-vocabs" file>>>report
|
||||
]
|
||||
when ;
|
||||
|
||||
: send-report ( -- )
|
||||
report get dispose
|
||||
"report" "../report" email-file ;
|
||||
] with-file-out ;
|
||||
|
||||
: build ( -- )
|
||||
[ (build) ]
|
||||
[ drop ]
|
||||
recover
|
||||
send-report ;
|
||||
[ (build) ] [ drop ] recover
|
||||
"report" "../report" email-file ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! : send-report ( -- )
|
||||
! report get dispose
|
||||
! "report" "../report" email-file ;
|
||||
|
||||
! : build ( -- )
|
||||
! [ (build) ]
|
||||
! [ drop ]
|
||||
! recover
|
||||
! send-report ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -10,28 +10,15 @@ USING: kernel namespaces sequences assocs builder continuations
|
|||
|
||||
IN: builder.test
|
||||
|
||||
: record-bootstrap-time ( -- )
|
||||
"../bootstrap-time" <file-writer>
|
||||
[ bootstrap-time get . ]
|
||||
with-stream ;
|
||||
|
||||
: do-load ( -- )
|
||||
[ try-everything keys ] "../load-everything-time" log-runtime
|
||||
dup empty?
|
||||
[ drop ]
|
||||
[ "../load-everything-vocabs" log-object ]
|
||||
if ;
|
||||
try-everything keys "../load-everything-vocabs" [ . ] with-file-out ;
|
||||
|
||||
: do-tests ( -- )
|
||||
[ run-all-tests keys ] "../test-all-time" log-runtime
|
||||
dup empty?
|
||||
[ drop ]
|
||||
[ "../test-all-vocabs" log-object ]
|
||||
if ;
|
||||
run-all-tests keys "../test-all-vocabs" [ . ] with-file-out ;
|
||||
|
||||
: do-all ( -- )
|
||||
record-bootstrap-time
|
||||
do-load
|
||||
do-tests ;
|
||||
bootstrap-time get "../boot-time" [ . ] with-file-out
|
||||
[ do-load ] runtime "../load-time" [ . ] with-file-out
|
||||
[ do-tests ] runtime "../test-time" [ . ] with-file-out ;
|
||||
|
||||
MAIN: do-all
|
||||
Loading…
Reference in New Issue