(zilch magic): support fallback CA drvs

A derivation can now be tagged with a fallback, which is substituted in
place of the failed derivation.

Change-Id: I6a6a696418b5d9ced3ba16ce458f55f23813c32b

core/src/magic.sld

@@ -4,6 +4,7 @@
 (define-library (zilch magic)
   (import
     (scheme base) (scheme file) (scheme lazy)
+    (chicken condition)
     (zilch lib hash) (zilch nix daemon) (zilch nix drv) (zilch nix path)
     (zilch nix hash)
     (zilch planner step)
@@ -23,6 +24,8 @@
     store-path-realised store-path-open
     store-path-devirtualise
 
+    store-path-register-fallback
+
     ca-thread-count drv-resolve-ca
 
     zilch-magic-counters)
@@ -322,34 +325,50 @@
       (rewrite-string str with-rewrites)))
 
    (define-record-type <pending-item>
-     (make-pending-item ca-drv ia-drv resolved-paths awaiting-count awaited-by)
+     (make-pending-item init-ca-drv ca-drv ia-drv resolved-paths awaiting-count awaited-by)
      pending-item?
-     (ca-drv pending-item-ca-drv)
+     ; Initial CA drv. used to resolve placeholders.
+     (init-ca-drv pending-item-init-ca-drv)
+     (ca-drv pending-item-ca-drv set-pending-item-ca-drv!)
      (ia-drv pending-item-ia-drv set-pending-item-ia-drv!)
      (resolved-paths pending-item-resolved-paths set-pending-item-resolved-paths!)
      (awaiting-count pending-item-awaiting-count set-pending-item-awaiting-count!)
      (awaited-by pending-item-awaited-by set-pending-item-awaited-by!))
 
    (define-record-printer (<pending-item> item out)
-    (fprintf out "#<pending-item ~A - awaiting ~S>" (derivation-path (pending-item-ca-drv item)) (pending-item-awaiting-count item)))
+    (fprintf out "#<pending-item ~A - awaiting ~S>" (derivation-path (pending-item-init-ca-drv item)) (pending-item-awaiting-count item)))
 
    (define ca-thread-count (make-parameter 4))
 
+   ; This function is a bit of a misnomer.
+   ; It (re)implements the entire Nix derivation builder, to support zilch-flavour
+   ; CA derivations.
    (define (rewrite-ca-stack input-drv)
-     ; A mapping of CA derivation path to <pending-item>.
+     (thread-specific-set! (current-thread) '())
+     ; A mapping of (initial) CA derivation path to <pending-item>.
      (define ca-to-pending-map (mapping (make-default-comparator)))
 
-     (define pending-mutex (make-mutex))
+     (define pending-mutex (make-mutex 'pending-mutex))
+     ; The count of pending .drvs to build, guarded by `pending-count-mutex`.
      (define pending-count 0)
-     (define build-error #f)
-     (define build-mutex (make-mutex))
-     (define build-condvar (make-condition-variable))
-     (define to-build '())
-     (define (depend-on pend item)
-       (set-pending-item-awaiting-count! pend (+ (pending-item-awaiting-count pend) 1))
-       (set-pending-item-awaited-by! item (cons pend (pending-item-awaited-by item))))
+     (define pending-count-mutex (make-mutex 'pending-count-mutex))
 
-     (define (handle-new-drv pend)
+     ; List of pending items that are ready to be built.
+     (define to-build '())
+     ; The first error seen whilst building.
+     (define build-error #f)
+     ; Mutex (and condvar) that guards `to-build`.
+     (define build-mutex (make-mutex 'build-mutex))
+     (define build-condvar (make-condition-variable))
+
+     ; Marks the pending item `pend` as depending on `item`.
+     (define (depend-on pend item)
+       (unless (pending-item-resolved-paths item)
+         (set-pending-item-awaiting-count! pend (+ (pending-item-awaiting-count pend) 1))
+         (set-pending-item-awaited-by! item (cons pend (pending-item-awaited-by item)))))
+
+     ; Marks `pend` as depending on all its inputs, and attempts to wake it.
+     (define (depend-on-inputs pend)
       (for-each
        (lambda (input-kv)
         (when (drv-is-ca (car input-kv))
@@ -358,28 +377,42 @@
       (wake-up pend)
       pend)
 
+     ; Attempts to wake up a pending item.
+     ; Takes and releases build-mutex.
      (define (wake-up pend)
       (when (eq? (pending-item-awaiting-count pend) 0)
        (set-pending-item-awaiting-count! pend 'build)
+       (mutex-unlock! pending-mutex)
        (mutex-lock! build-mutex)
        (set! to-build (cons pend to-build))
        (condition-variable-signal! build-condvar)
-       (mutex-unlock! build-mutex)))
+       (mutex-unlock! build-mutex)
+       (mutex-lock! pending-mutex)))
 
+     ; Attempts to look up `drv` in the `ca-to-pending-map`. If not found,
+     ; creates a new pending-item.
      (define (get-item drv)
       (unless (drv-is-ca drv) (error "drv not CA" (derivation-path drv)))
       (define pending (mapping-ref/default ca-to-pending-map (derivation-path drv) #f))
       (unless pending
-        (set! pending (make-pending-item drv #f '() 0 '()))
-        (mutex-lock! pending-mutex)
+        (set! pending (make-pending-item drv drv #f #f 0 '()))
+        (mutex-lock! pending-count-mutex)
         (unless (eq? pending-count 'error)
           (set! pending-count (+ pending-count 1)))
+        (mutex-unlock! pending-count-mutex)
         (set! ca-to-pending-map (mapping-set! ca-to-pending-map (derivation-path drv) pending))
-        (mutex-unlock! pending-mutex)
-        (handle-new-drv pending))
+        (depend-on-inputs pending))
       pending)
 
+     ; Attempts to build `item` against daemon connection `conn`.
+     ; Takes `pending-mutex`.
      (define (do-build conn item)
+       (call/cc
+        (lambda (cc)
+         (define fallback-drv
+          (let* ((meta (derivation-meta (pending-item-ca-drv item)))
+                 (fallback (and meta (assoc 'fallback meta))))
+           (and fallback (cdr fallback))))
          ; Rewrite CA drv to IA drv using the known inputs
          (define new-drvs (list))
          (define new-srcs (derivation-input-src (pending-item-ca-drv item)))
@@ -421,7 +454,22 @@
          ; Build all the paths.
          (parameterize ((*daemon* conn)) (write-drv-to-daemon ia-drv))
          (define outputs (map car (derivation-outputs ia-drv)))
-       (daemon-wop-build-paths conn (list->vector (map (lambda (v) (string-append (derivation-path ia-drv) "!" v)) outputs)))
+         (if fallback-drv
+          (with-exception-handler
+           (lambda (e)
+            ; We hit the failure path, and a fallback drv is available.
+            ; Update our pending CA drv, and mark the dependencies, and
+            ; bail out.
+            (print-error-message e (current-error-port))
+            (set-pending-item-ca-drv! item (fallback-drv))
+            (mutex-lock! pending-mutex)
+            (set-pending-item-awaiting-count! item 0)
+            (depend-on-inputs item)
+            (mutex-unlock! pending-mutex)
+            (cc #f))
+           (lambda ()
+            (daemon-wop-build-paths conn (list->vector (map (lambda (v) (string-append (derivation-path ia-drv) "!" v)) outputs)))))
+          (daemon-wop-build-paths conn (list->vector (map (lambda (v) (string-append (derivation-path ia-drv) "!" v)) outputs))))
          (set-pending-item-resolved-paths! item
           (map (lambda (o)
                  (define-values (name hash nar-size ca-store-path)
@@ -430,15 +478,24 @@
            outputs))
 
          ; Notify our dependencies that we're done.
-       (mutex-lock! pending-mutex)
+         (mutex-lock! pending-count-mutex)
          (unless (eq? pending-count 'error)
            (set! pending-count (- pending-count 1)))
-       (mutex-unlock! pending-mutex)
+         (mutex-unlock! pending-count-mutex)
+         (mutex-lock! pending-mutex)
          (set-pending-item-awaiting-count! item 'built)
-       (for-each (lambda (depends-on) (set-pending-item-awaiting-count! depends-on (- (pending-item-awaiting-count depends-on) 1)) (wake-up depends-on)) (pending-item-awaited-by item)))
-
+         (for-each
+          (lambda (depends-on)
+           (set-pending-item-awaiting-count! depends-on (- (pending-item-awaiting-count depends-on) 1))
+           (wake-up depends-on))
+          (pending-item-awaited-by item))
+         (mutex-unlock! pending-mutex))))
+     (mutex-lock! pending-mutex)
      (define root-pend (get-item input-drv))
+     (mutex-unlock! pending-mutex)
      (define (builder quit conn)
+       (unless (thread-specific (current-thread))
+        (thread-specific-set! (current-thread) '()))
        (mutex-lock! build-mutex)
        (define item #f)
        (when (pair? to-build)
@@ -451,10 +508,10 @@
           (mutex-unlock! build-mutex)
           (with-exception-handler
            (lambda (e)
-            (mutex-lock! pending-mutex)
+            (mutex-lock! pending-count-mutex)
             (set! pending-count 'error)
             (set! build-error e)
-            (mutex-unlock! pending-mutex)
+            (mutex-unlock! pending-count-mutex)
             (condition-variable-broadcast! build-condvar)
             (when (error-object? e)
               (fprintf (current-error-port) "~S ~A" (thread-name (current-thread)) (error-object-message e)))
@@ -464,9 +521,9 @@
           (builder quit conn))
          (begin
            ; Check how many pending items there are..
-           (mutex-lock! pending-mutex)
+           (mutex-lock! pending-count-mutex)
            (set! local-pending-count pending-count)
-           (mutex-unlock! pending-mutex)
+           (mutex-unlock! pending-count-mutex)
            (if (or (eq? local-pending-count 0) (eq? local-pending-count 'error))
              ; We're out of pending items, unlock the mutex and drop the thread
              (begin
@@ -543,6 +600,16 @@
        (daemon-wop-build-paths (*daemon*) (list->vector to-build)))
      val)
 
+   (define (store-path-register-fallback path fallback-thunk)
+     (define (wrap-fallback)
+      (define new (fallback-thunk))
+      (cond
+       ((and (list? new) (pair? (car new)) (store-path? (cdar new))) (store-path-drv (cdar new)))
+       ((store-path? new) (store-path-drv new))
+       (else new)))
+     (set-derivation-meta! (store-path-drv path) (cons (cons 'fallback wrap-fallback) (or (derivation-meta (store-path-drv path)) '())))
+     path)
+
    (register-build-step '((zilch core magic) build) #t
     (lambda items
       (printf "received build info: ~S\n" items)