puck/zilch
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

(zilch magic): Replace daemon-handled CA derivations with Zilch

Browse source 
Lix is deprecating CA derivations, and it's not too difficult to have
this be handled entirely by Zilch. This also improves stability and
future handling of the feature, as Zilch does not depend on how the
daemon handles CA derivations. Though right now, the behavior of
CA derivations is identical to that of the experimental feature, at
this time.

Building CA derivations requires a small scheduler to bypass the Nix
behavior. Each CA derivation is recorded, and then all derivations that
have no CA dependencies get built. These are used to resolve the
realisations for the derivations that depend upon them, and the the
cycle continues.
This commit is contained in:
puck 2025-05-11 22:21:07 +00:00
parent 83a4a0569d
commit 9b03914ec1
1 changed files with 196 additions and 80 deletions
Download patch file Download diff file Expand all files Collapse all files

264
core/src/magic.sld
View file

@ -8,7 +8,7 @@
(zilch nix hash) (zilch nix hash)
(zilch planner step) (zilch planner step)
(zilch zexpr) (zilch zexpr)
(srfi 128) (srfi 132) (srfi 146) (srfi 152) (srfi 207) (srfi 18) (srfi 128) (srfi 132) (srfi 146) (srfi 152) (srfi 207)
(chicken base) (chicken format) socket) (chicken base) (chicken format) socket)
(export (export
@ -103,9 +103,13 @@
(written store-path-written set-store-path-written!)) (written store-path-written set-store-path-written!))
(define-record-printer (<store-path> rt out) (define-record-printer (<store-path> rt out)
(if (eqv? (store-path-output rt) "") (cond
(fprintf out "#<store path ~A>" (store-path-path rt)) ((eqv? (store-path-output rt) "")
(fprintf out "#<store path ~A (~A!~A)>" (store-path-path rt) (derivation-path (store-path-drv rt)) (store-path-output rt)))) (fprintf out "#<store path ~A>" (store-path-path rt)))
((drv-is-ca (store-path-drv rt))
(fprintf out "#<store path ~A (ca~~ ~A!~A)>" (store-path-path rt) (derivation-path (store-path-drv rt)) (store-path-output rt)))
(else
(fprintf out "#<store path ~A (~A!~A)>" (store-path-path rt) (derivation-path (store-path-drv rt)) (store-path-output rt)))))
;; Returns the store path for the output associated with this `<store-path>`. ;; Returns the store path for the output associated with this `<store-path>`.
(define (store-path-path path) (define (store-path-path path)
@ -113,7 +117,7 @@
;; Makes sure the derivation referenced by this store path exists in the daemon. ;; Makes sure the derivation referenced by this store path exists in the daemon.
(define (store-path-materialize path) (define (store-path-materialize path)
(unless (store-path-written path) (unless (or (drv-is-ca (store-path-drv path)) (store-path-written path))
(write-drv-to-daemon (store-path-drv path)) (write-drv-to-daemon (store-path-drv path))
(set-store-path-written! path #t))) (set-store-path-written! path #t)))
@ -137,6 +141,7 @@
;; Writes the `<derivation>` to the Nix store, via the currently specified `*daemon*`. ;; Writes the `<derivation>` to the Nix store, via the currently specified `*daemon*`.
(define (write-drv-to-daemon drv) (define (write-drv-to-daemon drv)
(when (drv-is-ca drv) (error "tried materializing CA drv"))
(define path (derivation-path drv)) (define path (derivation-path drv))
(unless (file-exists? path) (unless (file-exists? path)
(let ((out (open-output-string))) (let ((out (open-output-string)))
@ -236,45 +241,20 @@
(define drv-output-map #f) (define drv-output-map #f)
(define placeholders-to-build '()) (define placeholders-to-build '())
(define (check-output-needs-building output-name output drv)
(when (and (derivation-output-placeholder? output) (string-contains path (derivation-output-path output)))
(unless drv-output-map
(set! drv-output-map (daemon-wop-query-derivation-output-map (*daemon*) (derivation-path drv))))
(let ((known-path (cdr (assoc output-name drv-output-map))))
(unless known-path
(set! placeholders-to-build (cons (string-append (derivation-path drv) "!" output-name) placeholders-to-build))))))
(define (process-output output-name output drv)
(define needs-building #f)
(when (and (derivation-output-placeholder? output) (string-contains path (derivation-output-path output)))
(unless drv-output-map
(set! drv-output-map (daemon-wop-query-derivation-output-map (*daemon*) (derivation-path drv))))
(let* ((known-path (cdr (assoc output-name drv-output-map)))
(is-replaced (replace-placeholder (derivation-output-path output) known-path 0)))
(when (and is-replaced (not (file-exists? known-path)))
(set! needs-building #t))))
(when (or needs-building (not (or (derivation-output-placeholder? output) (file-exists? (derivation-output-path output)))))
(set! context-to-build (cons (string-append (derivation-path drv) "!" output-name) context-to-build))))
(for-each (for-each
(lambda (drv-outputs) (lambda (drv-and-outputs)
(set! drv-output-map #f) (define drv (car drv-and-outputs))
(define ca-drv (drv-resolve-ca (car drv-and-outputs) (cdr drv-and-outputs)))
(when ca-drv
(for-each (for-each
(lambda (output-name) (lambda (output)
(check-output-needs-building output-name (cdr (assoc output-name (derivation-outputs (car drv-outputs)))) (car drv-outputs))) (define placeholder (derivation-output-path (cdr (assoc output (derivation-outputs drv)))))
(cdr drv-outputs))) (define new-path (cdr (assoc output ca-drv)))
(replace-placeholder placeholder new-path 0))
(cdr drv-and-outputs))))
drv-context) drv-context)
(unless (null? placeholders-to-build)
(daemon-wop-build-paths (*daemon*) (list->vector placeholders-to-build))) path)
(for-each
(lambda (drv-outputs)
(set! drv-output-map #f)
(for-each
(lambda (output-name)
(process-output output-name (cdr (assoc output-name (derivation-outputs (car drv-outputs)))) (car drv-outputs)))
(cdr drv-outputs)))
drv-context)
(values path context-to-build))
(define (zexp-ctx-has-placeholder drv-context) (define (zexp-ctx-has-placeholder drv-context)
(if (null? drv-context) (if (null? drv-context)
@ -311,42 +291,180 @@
(string-concatenate-reverse parts) (string-concatenate-reverse parts)
str)) str))
(define (drv-resolve-ca drv needed-outputs) (define (rewrite-bytevector str with-rewrites)
(if (drv-is-ca drv) (define parts '())
(let (define (find-part-at i last-i)
((new-drvs (list)) (new-srcs (derivation-input-src drv)) (rewrites (list))) (define next-slash (bytestring-index str (lambda (c) (= c #x2F)) i))
; For each drv, figure out if we need to CA it. (if (or (not next-slash) (>= next-slash (- (bytevector-length str) 53)))
(if (= last-i 0)
(set! parts #f)
(set! parts (cons (bytevector-copy str last-i) parts)))
(let* ((actual-string (utf8->string (bytevector-copy str next-slash (+ next-slash 53))))
(mapping-pair (assoc actual-string with-rewrites string=?)))
; If we have a mapping for this string, replace it and continue.
(if mapping-pair
(begin (begin
(set! parts (cons (string->utf8 (cdr mapping-pair)) (cons (bytevector-copy str last-i next-slash) parts)))
(find-part-at (+ next-slash 53) (+ next-slash 53)))
(find-part-at (+ next-slash 1) last-i)))))
(find-part-at 0 0)
(if (pair? parts)
(apply bytevector-append (reverse parts))
str))
(define (rewrite-string-or-bytevector str with-rewrites)
(if (bytevector? str)
(rewrite-bytevector str with-rewrites)
(rewrite-string str with-rewrites)))
(define-record-type <pending-item>
(make-pending-item ca-drv ia-drv resolved-paths awaiting-count awaited-by)
pending-item?
(ca-drv 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)))
(define (rewrite-ca-stack input-drv)
; A mapping of CA derivation path to <pending-item>.
(define ca-to-pending-map (mapping (make-default-comparator)))
(define pending-mutex (make-mutex))
(define pending-count 0)
(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 (handle-new-drv pend)
(for-each
(lambda (input-kv)
(when (drv-is-ca (car input-kv))
(depend-on pend (get-item (car input-kv)))))
(derivation-input-drvs (pending-item-ca-drv pend)))
(wake-up pend)
pend)
(define (wake-up pend)
(when (eq? (pending-item-awaiting-count pend) 0)
(set-pending-item-awaiting-count! pend 'build)
(mutex-lock! build-mutex)
(set! to-build (cons pend to-build))
(condition-variable-signal! build-condvar)
(mutex-unlock! build-mutex)))
(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-count (+ pending-count 1))
(set! ca-to-pending-map (mapping-set! ca-to-pending-map (derivation-path drv) pending))
(mutex-unlock! pending-mutex)
(handle-new-drv pending))
pending)
(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 (for-each
(lambda (drv-and-outputs) (lambda (drv-and-outputs)
(define ca-outputs (drv-resolve-ca (car drv-and-outputs) (cdr drv-and-outputs))) (mutex-lock! pending-mutex)
(if (not ca-outputs) (define dep-pend (mapping-ref/default ca-to-pending-map (derivation-path (car drv-and-outputs)) #f))
; It's not CA'd, so add it back (mutex-unlock! pending-mutex)
(set! new-drvs (cons drv-and-outputs new-drvs)) (if dep-pend
; Iterate over each output path, and add its CA equivalent to the input list here.
; Find the CA paths matching the input paths (this is basically equivalent to daemon-wop-query-derivation-output-map!)
; Also record the rewrites!
(for-each (for-each
(lambda (output) (lambda (output)
(set! new-srcs (cons (cdr (assoc output (cdr ca-outputs))) new-srcs)) (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))))) (define old-output (cdr (assoc output (derivation-outputs (car drv-and-outputs)))))
(set! rewrites (cons (cons (derivation-output-path old-output) (cdr (assoc output (cdr ca-outputs)))) rewrites))) (set! rewrites (cons (cons (derivation-output-path old-output) new-path) rewrites)))
(cdr drv-and-outputs)))) (cdr drv-and-outputs))
(derivation-input-drvs drv))
; Now we rewrite the builder and environment. ; Not a CA drv, add it back to the drvs list
(let* (set! new-drvs (cons drv-and-outputs new-drvs))))
((new-builder (rewrite-string (derivation-builder drv) rewrites)) (derivation-input-drvs (pending-item-ca-drv item)))
(new-args (map (lambda (v) (rewrite-string v rewrites)) (derivation-args drv)))
(new-env (map (lambda (kv) (cons (car kv) (rewrite-string (cdr kv) rewrites))) (derivation-env drv))) (define ca-drv (pending-item-ca-drv item))
(new-drv (make-input-addressed-derivation (define new-builder (rewrite-string-or-bytevector (derivation-builder ca-drv) rewrites))
(derivation-name drv) (define new-args (map (lambda (v) (rewrite-string-or-bytevector v rewrites)) (derivation-args ca-drv)))
(derivation-system drv) (define new-env (map (lambda (kv) (cons (car kv) (rewrite-string-or-bytevector (cdr kv) rewrites))) (derivation-env ca-drv)))
new-drvs new-srcs (cons new-builder new-args) new-env (map car (derivation-outputs drv))))) (define ia-drv
(write-drv-to-daemon new-drv) (make-input-addressed-derivation
(daemon-wop-build-paths (*daemon*) (list->vector (map (lambda (v) (string-append (derivation-path new-drv) "!" v)) needed-outputs))) (derivation-name ca-drv)
(map (lambda (o) (define-values (name hash nar-size ca-store-path) (store-path-to-fod (*daemon*) (derivation-output-path (cdr (assoc o (derivation-outputs new-drv) string=?))))) ca-store-path) (derivation-system ca-drv)
needed-outputs)))) (list-sort
; Not a CA drv. (lambda (l r) (string<? (derivation-path (car l)) (derivation-path (car r))))
new-drvs)
(list-sort string<? new-srcs)
(cons new-builder new-args) new-env (map car (derivation-outputs ca-drv))))
(set-pending-item-ia-drv! item ia-drv)
; 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)))
(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)
(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)))
(define root-pend (get-item input-drv))
(define (builder conn)
(mutex-lock! build-mutex)
(define item #f)
(when (pair? to-build)
(set! item (car to-build))
(set! to-build (cdr to-build)))
(define local-pending-count #f)
(if item
; If we got an item: unlock the build mutex and build it
(begin (mutex-unlock! build-mutex) (do-build conn item) (builder conn))
(begin
; Check how many pending items there are..
(mutex-lock! pending-mutex)
(set! local-pending-count pending-count)
(mutex-unlock! pending-mutex)
(if (= local-pending-count 0)
; We're out of pending items, unlock the mutex and drop the thread
(begin
(mutex-unlock! build-mutex)
; Notify the other threads that we have no more builds to do.
(condition-variable-broadcast! build-condvar))
; We still have pending items, let's go back and wait.
(begin
(mutex-unlock! build-mutex build-condvar)
(builder conn))))))
(define builder-threads (list))
(do ((i 0 (+ i 1))) ((>= i 16) #f)
(set! builder-threads (cons (thread-start! (make-thread (lambda () (builder (daemon-connect))) (string-append "ca-builder-" (number->string i)))) builder-threads)))
(for-each thread-join! builder-threads)
root-pend)
(define (drv-resolve-ca drv outputs)
(if (drv-is-ca drv)
(pending-item-resolved-paths (rewrite-ca-stack drv))
#f)) #f))
(define (store-path-realised path) (define (store-path-realised path)
@ -362,9 +480,7 @@
(cdr drv-and-outputs)))) (cdr drv-and-outputs))))
(zexp-evaluation-drvs ctx)) (zexp-evaluation-drvs ctx))
(if (string? val) (if (string? val)
(let-values (((resolved resolved-to-build) (resolve-upstream-output-placeholders val (zexp-evaluation-drvs ctx)))) (set! val (resolve-upstream-output-placeholders val (zexp-evaluation-drvs ctx)))
(set! val resolved)
(set! to-build resolved-to-build))
(when (zexp-ctx-has-placeholder (zexp-evaluation-drvs ctx)) (when (zexp-ctx-has-placeholder (zexp-evaluation-drvs ctx))
(error "store-path-realised: expression has dependencies on placeholder context, but isn't a string" (list path val)))) (error "store-path-realised: expression has dependencies on placeholder context, but isn't a string" (list path val))))
(when (and (string? val) (not (file-exists? val)) (not (null? to-build))) (when (and (string? val) (not (file-exists? val)) (not (null? to-build)))