From 9382082702e6a064f7721865f6ec9817c7770161 Mon Sep 17 00:00:00 2001 From: Puck Meerburg Date: Fri, 13 Jun 2025 21:15:21 +0000 Subject: [PATCH] (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 | 217 +++++++++++++++++++++++++++++---------------- 1 file changed, 142 insertions(+), 75 deletions(-) diff --git a/core/src/magic.sld b/core/src/magic.sld index 6c22fc4..a16c068 100644 --- a/core/src/magic.sld +++ b/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 - (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 ( item out) - (fprintf out "#" (derivation-path (pending-item-ca-drv item)) (pending-item-awaiting-count item))) + (fprintf out "#" (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 . + (thread-specific-set! (current-thread) '()) + ; A mapping of (initial) CA derivation path to . (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,87 +377,125 @@ (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) - ; 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))) - (define rewrites (list)) - (for-each - (lambda (drv-and-outputs) - (mutex-lock! pending-mutex) - (define dep-pend (mapping-ref/default ca-to-pending-map (derivation-path (car drv-and-outputs)) #f)) - (mutex-unlock! pending-mutex) - (if dep-pend - ; Iterate over each output path, and add its CA equivalent to the input list here. - (for-each - (lambda (output) - (define new-path (cdr (assoc output (pending-item-resolved-paths dep-pend)))) - (set! new-srcs (cons new-path new-srcs)) - (define old-output (cdr (assoc output (derivation-outputs (car drv-and-outputs))))) - (set! rewrites (cons (cons (derivation-output-path old-output) new-path) rewrites))) - (cdr drv-and-outputs)) + (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))) + (define rewrites (list)) + (for-each + (lambda (drv-and-outputs) + (mutex-lock! pending-mutex) + (define dep-pend (mapping-ref/default ca-to-pending-map (derivation-path (car drv-and-outputs)) #f)) + (mutex-unlock! pending-mutex) + (if dep-pend + ; Iterate over each output path, and add its CA equivalent to the input list here. + (for-each + (lambda (output) + (define new-path (cdr (assoc output (pending-item-resolved-paths dep-pend)))) + (set! new-srcs (cons new-path new-srcs)) + (define old-output (cdr (assoc output (derivation-outputs (car drv-and-outputs))))) + (set! rewrites (cons (cons (derivation-output-path old-output) new-path) rewrites))) + (cdr drv-and-outputs)) - ; Not a CA drv, add it back to the drvs list - (set! new-drvs (cons drv-and-outputs new-drvs)))) - (derivation-input-drvs (pending-item-ca-drv item))) + ; Not a CA drv, add it back to the drvs list + (set! new-drvs (cons drv-and-outputs new-drvs)))) + (derivation-input-drvs (pending-item-ca-drv item))) - (define ca-drv (pending-item-ca-drv item)) - (define new-builder (rewrite-string-or-bytevector (derivation-builder ca-drv) rewrites)) - (define new-args (map (lambda (v) (rewrite-string-or-bytevector v rewrites)) (derivation-args ca-drv))) - (define new-env (map (lambda (kv) (cons (car kv) (rewrite-string-or-bytevector (cdr kv) rewrites))) (derivation-env ca-drv))) - (define ia-drv - (make-input-addressed-derivation - (derivation-name ca-drv) - (derivation-system ca-drv) - (list-sort - (lambda (l r) (stringvector (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) - (store-path-to-fod conn (derivation-output-path (cdr (assoc o (derivation-outputs ia-drv) string=?))))) - (cons o ca-store-path)) - outputs)) - - ; Notify our dependencies that we're done. - (mutex-lock! pending-mutex) - (unless (eq? pending-count 'error) - (set! pending-count (- pending-count 1))) - (mutex-unlock! 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))) + ; Build all the paths. + (parameterize ((*daemon* conn)) (write-drv-to-daemon ia-drv)) + (define outputs (map car (derivation-outputs ia-drv))) + (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) + (store-path-to-fod conn (derivation-output-path (cdr (assoc o (derivation-outputs ia-drv) string=?))))) + (cons o ca-store-path)) + outputs)) + ; Notify our dependencies that we're done. + (mutex-lock! pending-count-mutex) + (unless (eq? pending-count 'error) + (set! pending-count (- pending-count 1))) + (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)) + (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)