[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Mathieu Othacehe |
|
Date: |
Tue, 24 Nov 2020 11:52:58 -0500 (EST) |
branch: wip-offload
commit 89ef7a380354f16afe62bbcb91d4bffb893c37b6
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Thu Nov 19 11:33:19 2020 +0100
offload support.
---
bin/cuirass.in | 159 ++++++++++++++++++++++++++-------------------------
src/cuirass/base.scm | 49 +++++++++++++++-
2 files changed, 127 insertions(+), 81 deletions(-)
diff --git a/bin/cuirass.in b/bin/cuirass.in
index aef4a65..5b1327a 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -141,84 +141,87 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0"
"$@"
(lambda ()
(with-database
(with-queue-writer-worker
- (and specfile
- (let ((new-specs (save-module-excursion
- (lambda ()
- (set-current-module (make-user-module
'()))
- (primitive-load specfile)))))
- (for-each db-add-specification new-specs)))
-
- (when queries-file
- (log-message "Enable SQL query logging.")
- (db-log-queries queries-file))
-
- (if one-shot?
- (process-specs (db-get-specifications))
- (let ((exit-channel (make-channel)))
- (start-watchdog)
- (if (option-ref opts 'web #f)
- (begin
- (spawn-fiber
- (essential-task
- 'web exit-channel
- (lambda ()
- (run-cuirass-server #:host host #:port port)))
- #:parallel? #t)
-
- (spawn-fiber
- (essential-task
- 'monitor exit-channel
- (lambda ()
- (while #t
- (log-monitoring-stats)
- (sleep 600))))))
-
- (begin
- (clear-build-queue)
-
- ;; If Cuirass was stopped during an evaluation,
- ;; abort it. Builds that were not registered
- ;; during this evaluation will be registered
- ;; during the next evaluation.
- (db-abort-pending-evaluations)
-
- ;; First off, restart builds that had not
- ;; completed or were not even started on a
- ;; previous run.
- (spawn-fiber
- (essential-task
- 'restart-builds exit-channel
- (lambda ()
- (restart-builds))))
-
- (spawn-fiber
- (essential-task
- 'build exit-channel
- (lambda ()
- (while #t
- (process-specs (db-get-specifications))
- (log-message
- "next evaluation in ~a seconds" interval)
- (sleep interval)))))
-
- (spawn-fiber
- (essential-task
- 'metrics exit-channel
- (lambda ()
- (while #t
- (with-time-logging
- "Metrics update"
- (db-update-metrics))
- (sleep 3600)))))
-
- (spawn-fiber
- (essential-task
- 'monitor exit-channel
- (lambda ()
- (while #t
- (log-monitoring-stats)
- (sleep 600)))))))
- (primitive-exit (get-message exit-channel)))))))
+ (with-build-offload-thread
+ (and specfile
+ (let ((new-specs (save-module-excursion
+ (lambda ()
+ (set-current-module
+ (make-user-module '()))
+ (primitive-load specfile)))))
+ (for-each db-add-specification new-specs)))
+
+ (when queries-file
+ (log-message "Enable SQL query logging.")
+ (db-log-queries queries-file))
+
+ (if one-shot?
+ (process-specs (db-get-specifications))
+ (let ((exit-channel (make-channel)))
+ (start-watchdog)
+ (if (option-ref opts 'web #f)
+ (begin
+ (spawn-fiber
+ (essential-task
+ 'web exit-channel
+ (lambda ()
+ (run-cuirass-server #:host host
+ #:port port)))
+ #:parallel? #t)
+
+ (spawn-fiber
+ (essential-task
+ 'monitor exit-channel
+ (lambda ()
+ (while #t
+ (log-monitoring-stats)
+ (sleep 600))))))
+
+ (begin
+ (clear-build-queue)
+
+ ;; If Cuirass was stopped during an evaluation,
+ ;; abort it. Builds that were not registered
+ ;; during this evaluation will be registered
+ ;; during the next evaluation.
+ (db-abort-pending-evaluations)
+
+ ;; First off, restart builds that had not
+ ;; completed or were not even started on a
+ ;; previous run.
+ (spawn-fiber
+ (essential-task
+ 'restart-builds exit-channel
+ (lambda ()
+ (restart-builds))))
+
+ (spawn-fiber
+ (essential-task
+ 'build exit-channel
+ (lambda ()
+ (while #t
+ (process-specs (db-get-specifications))
+ (log-message
+ "next evaluation in ~a seconds" interval)
+ (sleep interval)))))
+
+ (spawn-fiber
+ (essential-task
+ 'metrics exit-channel
+ (lambda ()
+ (while #t
+ (with-time-logging
+ "Metrics update"
+ (db-update-metrics))
+ (sleep 3600)))))
+
+ (spawn-fiber
+ (essential-task
+ 'monitor exit-channel
+ (lambda ()
+ (while #t
+ (log-monitoring-stats)
+ (sleep 600)))))))
+ (primitive-exit (get-message exit-channel))))))))
;; Most of our code is I/O so preemption doesn't matter much (it
;; could help while we're doing SQL requests, for instance, but it
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 1966ad6..e9bd943 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -22,6 +22,7 @@
(define-module (cuirass base)
#:use-module (fibers)
+ #:use-module (fibers channels)
#:use-module (cuirass logging)
#:use-module (cuirass database)
#:use-module (cuirass utils)
@@ -29,6 +30,7 @@
#:use-module (gnu packages)
#:use-module (guix build utils)
#:use-module (guix derivations)
+ #:use-module (guix offload)
#:use-module (guix store)
#:use-module (guix git)
#:use-module (guix cache)
@@ -36,9 +38,13 @@
#:use-module ((guix config) #:select (%state-directory))
#:use-module (git)
#:use-module (ice-9 binary-ports)
+ #:use-module ((ice-9 suspendable-ports)
+ #:select (current-read-waiter
+ current-write-waiter))
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
+ #:use-module (ice-9 ports internal)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
@@ -65,6 +71,7 @@
prepare-git
process-specs
evaluation-log-file
+ with-build-offload-thread
;; Parameters.
%package-cachedir
@@ -110,6 +117,9 @@
;; Define whether to fall back to building when the substituter fails.
(make-parameter #f))
+(define %build-offload-channel
+ (make-parameter #f))
+
(define %package-cachedir
;; Define to location of cache directory of this package.
(make-parameter (or (getenv "CUIRASS_CACHEDIR")
@@ -436,6 +446,36 @@ Essentially this procedure inverts the
inversion-of-control that
(raise c))
(x x)))))))
+(define (make-build-offload-thread)
+ (let ((channel (make-channel)))
+ (call-with-new-thread
+ (lambda ()
+ (parameterize (((@@ (fibers internal) current-fiber) #f)
+ (current-read-waiter (lambda (port)
+ (port-poll port "r")))
+ (current-write-waiter (lambda (port)
+ (port-poll port "w"))))
+ (let ((socket (offload-socket)))
+ (let loop ()
+ (offload-poll socket handle-build-event
+ #:cache-directory "/tmp/offload")
+ (match (get-message-with-timeout channel
+ #:seconds 1
+ #:retry? #f)
+ ((drvs . systems)
+ (offload-build socket drvs systems))
+ ('timeout #f))
+ (loop))))))
+ channel))
+
+(define-syntax-rule (with-build-offload-thread body ...)
+ (parameterize ((%build-offload-channel
+ (make-build-offload-thread)))
+ body ...))
+
+(define (build-derivations/offload drvs systems)
+ (put-message (%build-offload-channel) (cons drvs systems)))
+
;;;
;;; Building packages.
@@ -641,7 +681,9 @@ started)."
;; Those in VALID can be restarted. If some of them were built in the
;; meantime behind our back, that's fine: 'spawn-builds' will DTRT.
(log-message "restarting ~a pending builds" (length valid))
- (spawn-builds store valid)
+ (let* ((builds (filter-map (cut db-get-build <>) valid))
+ (systems (map (cut assq-ref <> #:system) builds)))
+ (build-derivations/offload valid systems))
(log-message "done with restarted builds"))))
(define (create-build-outputs build product-specs)
@@ -734,8 +776,9 @@ by PRODUCT-SPECS."
(log-message "fetching input '~a' of spec '~a'"
(assq-ref input #:name)
(assq-ref spec #:name))
- (fetch-input store input
- #:writable-copy? (compile? input)))))
+ (parameterize ((current-error-port (%make-void-port "rw+")))
+ (fetch-input store input
+ #:writable-copy? (compile? input))))))
inputs))
(results (map %non-blocking thunks)))
(map (lambda (checkout)