steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

builder: another refactoring

db4
Eduardo Cavazos 2008-02-12 04:42:47 -06:00
parent 83f1bc5d8c
commit 336ad674d7
2 changed files with 150 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

225
extra/builder/builder.factor
View File

@ -1,6 +1,6 @@
USING: kernel parser io io.files io.launcher io.sockets hashtables math threads 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 prettyprint tools.time calendar bake vars http.client
combinators bootstrap.image bootstrap.image.download combinators bootstrap.image bootstrap.image.download
combinators.cleave ; combinators.cleave ;
@ -11,10 +11,10 @@ IN: builder
: runtime ( quot -- time ) benchmark nip ; : runtime ( quot -- time ) benchmark nip ;
: log-runtime ( quot file -- ) ! : log-runtime ( quot file -- )
>r runtime r> <file-writer> [ . ] with-stream ; ! >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 -- ) ! : run-or-notify ( desc message -- )
[ [ try-process ] curry ] ! [ [ try-process ] curry ]
[ [ email-string throw ] curry ] ! [ [ email-string throw ] curry ]
bi* ! bi*
recover ; ! recover ;
: run-or-send-file ( desc message file -- ) ! : run-or-send-file ( desc message file -- )
>r >r [ try-process ] curry ! >r >r [ try-process ] curry
r> r> [ email-file throw ] 2curry ! r> r> [ email-file throw ] 2curry
recover ; ! recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -98,7 +98,9 @@ VAR: stamp
: git-id ( -- id ) : git-id ( -- id )
{ "git" "show" } <process-stream> [ readln ] with-stream " " split second ; { "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" } ; : make-clean ( -- desc ) { "make" "clean" } ;
@ -110,12 +112,12 @@ VAR: stamp
} }
>hashtable ; >hashtable ;
: retrieve-boot-image ( -- ) ! : retrieve-boot-image ( -- )
[ my-arch download-image ] ! [ my-arch download-image ]
[ ] ! [ ]
[ "builder: image download" email-string ] ! [ "builder: image download" email-string ]
cleanup ! cleanup
flush ; ! flush ;
: bootstrap ( -- desc ) : 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 -- ) ! : run-or-report ( desc quot -- )
[ [ try-process ] curry ] ! [ [ try-process ] curry ]
[ [ >>>report throw ] curry ] ! [ [ >>>report throw ] curry ]
bi* ! bi*
recover ; ! recover ;
: run-or-report-file ( desc quot file -- ) ! : run-or-report-file ( desc quot file -- )
[ [ try-process ] curry ] ! [ [ try-process ] curry ]
[ [ >>>report ] curry ] ! [ [ >>>report ] curry ]
[ [ file>>>report throw ] curry ] ! [ [ file>>>report throw ] curry ]
tri* ! tri*
compose ! compose
recover ; ! recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -194,16 +196,83 @@ SYMBOL: report
! : bootstrap-minutes ( -- ) ! : bootstrap-minutes ( -- )
! "../bootstrap-time" <file-reader> contents eval ms>minutes unparse ; ! "../bootstrap-time" <file-reader> contents eval ms>minutes unparse ;
: min-and-sec ( milliseconds -- str ) ! : min-and-sec ( milliseconds -- str )
1000 /i 60 /mod swap ! 1000 /i 60 /mod swap
`{ ,[ number>string ] " minutes and " ,[ number>string ] " seconds" } ! `{ ,[ number>string ] " minutes and " ,[ number>string ] " seconds" }
concat ; ! 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 ; : 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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -211,14 +280,12 @@ SYMBOL: report
enter-build-dir enter-build-dir
"report" <file-writer> report set "report" [
[ "Build machine: " write host-name print
"Build machine: " write host-name write nl "Build directory: " write cwd print
"Build directory: " write cwd write nl
] >>>report
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
@ -226,48 +293,40 @@ SYMBOL: report
make-clean run-process drop make-clean run-process drop
make-vm make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
[ "Builder fatal error: vm compile error" write nl ]
"../compile-log"
run-or-report-file
[ my-arch download-image ] [ my-arch download-image ] [ "Image download error" print throw ] recover
[ [ "Builder fatal error: image download" write nl ] >>>report throw ]
bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
[ builder-test try-process ]
[ "Builder test error" print throw ]
recover recover
bootstrap [ "Bootstrap error" write nl ] "../boot-log" run-or-report-file "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
builder-test [ "Builder test error" write nl ] run-or-report "Did not pass load-everything: " print "../load-everything-vocabs" cat
"Did not pass test-all: " print "../test-all-vocabs" cat
[ ] with-file-out ;
"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 ;
: send-report ( -- )
report get dispose
"report" "../report" email-file ;
: build ( -- ) : build ( -- )
[ (build) ] [ (build) ] [ drop ] recover
[ drop ] "report" "../report" email-file ;
recover
send-report ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : send-report ( -- )
! report get dispose
! "report" "../report" email-file ;
! : build ( -- )
! [ (build) ]
! [ drop ]
! recover
! send-report ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

23
extra/builder/test/test.factor
View File

@ -10,28 +10,15 @@ USING: kernel namespaces sequences assocs builder continuations
IN: builder.test IN: builder.test
: record-bootstrap-time ( -- )
"../bootstrap-time" <file-writer>
[ bootstrap-time get . ]
with-stream ;
: do-load ( -- ) : do-load ( -- )
[ try-everything keys ] "../load-everything-time" log-runtime try-everything keys "../load-everything-vocabs" [ . ] with-file-out ;
dup empty?
[ drop ]
[ "../load-everything-vocabs" log-object ]
if ;
: do-tests ( -- ) : do-tests ( -- )
[ run-all-tests keys ] "../test-all-time" log-runtime run-all-tests keys "../test-all-vocabs" [ . ] with-file-out ;
dup empty?
[ drop ]
[ "../test-all-vocabs" log-object ]
if ;
: do-all ( -- ) : do-all ( -- )
record-bootstrap-time bootstrap-time get "../boot-time" [ . ] with-file-out
do-load [ do-load ] runtime "../load-time" [ . ] with-file-out
do-tests ; [ do-tests ] runtime "../test-time" [ . ] with-file-out ;
MAIN: do-all MAIN: do-all