Merge branch 'master' of git://factorcode.org/git/factor

extra/builder/benchmark/benchmark.factor

@@ -0,0 +1,41 @@
+
+USING: kernel continuations arrays assocs sequences sorting math
+       io io.styles prettyprint builder.util ;
+
+IN: builder.benchmark
+
+: passing-benchmarks ( table -- table )
+  [ second first2 number? swap number? and ] subset ;
+
+: simplify-table ( table -- table ) [ first2 second 2array ] map ;
+
+: benchmark-difference ( old-table benchmark-result -- result-diff )
+  first2 >r
+  tuck swap at
+  r>
+  swap -
+  2array ;
+
+: compare-tables ( old new -- table )
+  [ passing-benchmarks simplify-table ] 2apply
+  [ benchmark-difference ] with map ;
+
+: benchmark-deltas ( -- table )
+  "../../benchmarks" "../benchmarks" [ eval-file ] 2apply
+  compare-tables
+  sort-values ;
+
+: benchmark-deltas. ( deltas -- )
+  standard-table-style
+    [
+      [ [ "Benchmark" write ] with-cell [ "Delta (ms)" write ] with-cell ]
+      with-row
+      [ [ swap [ write ] with-cell pprint-cell ] with-row ]
+      assoc-each
+    ]
+  tabular-output ;
+
+: show-benchmark-deltas ( -- )
+  [ benchmark-deltas benchmark-deltas. ]
+    [ drop "Error generating benchmark deltas" . ]
+  recover ;

extra/builder/builder.factor

@@ -1,7 +1,8 @@
 
 USING: kernel namespaces sequences splitting system combinators continuations
        parser io io.files io.launcher io.sockets prettyprint threads
-       bootstrap.image benchmark vars bake smtp builder.util accessors ;
+       bootstrap.image benchmark vars bake smtp builder.util accessors
+       builder.benchmark ;
 
 IN: builder
 
@@ -61,6 +62,17 @@ VAR: stamp
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: copy-image ( -- )
+  "../../factor/" my-boot-image-name append
+  "../"           my-boot-image-name append
+  copy-file
+
+  "../../factor/" my-boot-image-name append
+                  my-boot-image-name
+  copy-file ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : factor-binary ( -- name )
   os
   { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
@@ -69,8 +81,7 @@ VAR: stamp
   case ;
 
 : bootstrap-cmd ( -- cmd )
-  { factor-binary [ "-i=" my-boot-image-name append ] "-no-user-init" }
+  { factor-binary { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
-  to-strings ;
 
 : bootstrap ( -- desc )
   <process*>
@@ -81,8 +92,18 @@ VAR: stamp
     20 minutes>ms >>timeout
   >desc ;
 
-: builder-test ( -- desc ) { factor-binary "-run=builder.test" } to-strings ;
+: builder-test-cmd ( -- cmd )
-  
+  { factor-binary "-run=builder.test" } to-strings ;
+
+: builder-test ( -- desc )
+  <process*>
+    builder-test-cmd >>arguments
+    +closed+         >>stdin
+    "../test-log"    >>stdout
+    +stdout+         >>stderr
+    45 minutes>ms    >>timeout
+  >desc ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 SYMBOL: build-status
@@ -112,13 +133,13 @@ SYMBOL: build-status
 
     make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
 
-    [ retrieve-image ] [ "Image download error" print throw ] recover
+    copy-image
 
     bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
 
-    [ builder-test try-process ]
+    builder-test [ "Test error" print "../test-log" cat ] run-or-bail
-    [ "Builder test error" print throw ]
+
-    recover
+    "../test-log" delete-file
 
     "Boot time: " write "../boot-time" eval-file milli-seconds>time print
     "Load time: " write "../load-time" eval-file milli-seconds>time print
@@ -130,6 +151,12 @@ SYMBOL: build-status
     "Benchmarks: " print
     "../benchmarks" [ stdio get contents eval ] with-file-reader benchmarks.
 
+    nl
+    
+    show-benchmark-deltas
+
+    "../benchmarks" "../../benchmarks" copy-file    
+
   ] with-file-writer
 
   build-status on ;
@@ -152,12 +179,17 @@ SYMBOL: builder-recipients
     "../report" file>string >>body
   send ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : build ( -- )
   [ (build) ] [ drop ] recover
-  [ send-builder-email ] [ drop "not sending mail" . ] recover ;
+  [ send-builder-email ] [ drop "not sending mail" . ] recover
+  ".." cd { "rm" "-rf" "factor" } run-process drop ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+USE: bootstrap.image.download
+
 : git-pull ( -- desc )
   {
     "git"
@@ -173,11 +205,17 @@ SYMBOL: builder-recipients
   git-id
   = not ;
 
+: new-image-available? ( -- ? )
+  my-boot-image-name need-new-image?
+    [ download-my-image t ]
+    [ f ]
+  if ;
+
 : build-loop ( -- )
   builds-check
   [
     builds "/factor" append cd
-    updates-available?
+    updates-available? new-image-available? or
       [ build ]
     when
   ]

extra/builder/server/server.factor

@@ -1,68 +0,0 @@
-
-USING: kernel continuations namespaces threads match bake concurrency builder ;
-
-IN: builder.server
-
-! : build-server ( -- )
-!   receive
-!   {
-!     {
-!       "start"
-!       [ [ build ] in-thread ]
-!     }
-
-!     {
-!       { ?from ?tag "status" }
-!       [ `{ ?tag ,[ build-status get ] } ?from send ]
-!     }
-!   }
-!   match-cond
-!   build-server ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : build-server ( -- )
-!   receive
-!   {
-!     {
-!       "start"
-!       [
-!         [ [ build ] [ drop ] recover "idle" build-status set-global ] in-thread
-!       ]
-!     }
-
-!     {
-!       { ?from ?tag "status" }
-!       [ `{ ?tag ,[ build-status get ] } ?from send ]
-!     }
-!   }
-!   match-cond
-!   build-server ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : build-server ( -- )
-!   receive
-!   {
-!     {
-!       "start"
-!       [
-!         build-status get "idle" =
-!         build-status get f      =
-!         or
-!         [
-!           [ [ build ] [ drop ] recover "idle" build-status set-global ]
-!           in-thread
-!         ]
-!         when
-!       ]
-!     }
-
-!     {
-!       { ?from ?tag "status" }
-!       [ `{ ?tag ,[ build-status get ] } ?from send ]
-!     }
-!   }
-!   match-cond
-!   build-server ;
-

misc/factor.el

@@ -110,8 +110,8 @@
 
 (require 'comint)
 
-(defvar factor-binary "/scratch/repos/Factor/factor")
+(defvar factor-binary "~/factor/factor")
-(defvar factor-image "/scratch/repos/Factor/factor.image")
+(defvar factor-image "~/factor/factor.image")
 
 (defun factor-telnet-to-port (port)
   (interactive "nPort: ")
@@ -202,8 +202,8 @@
 (defun run-factor ()
   (interactive)
   (switch-to-buffer
-   (make-comint-in-buffer "factor" nil factor-binary nil
+   (make-comint-in-buffer "factor" nil (expand-file-name factor-binary) nil
-			  (concat "-i=" factor-image)
+			  (concat "-i=" (expand-file-name factor-image))
 			  "-run=listener"))
   (factor-listener-mode))