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

(zilch magic): support devirtualising zexpr without losing zexpr-ness

Browse source 
Change-Id: I6a6a6964787b3a1fcd3223df258e34a8daba5dc8
This commit is contained in:
puck 2025-05-11 22:21:07 +00:00
parent c685ff31df
commit 0c0c4b5d22
1 changed files with 38 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

53
core/src/magic.sld
View file

@ -3,7 +3,7 @@
;; A `<store-path>` unquotes in `zexp`s as its store path.
(define-library (zilch magic)
(import
(scheme base) (scheme file)
(scheme base) (scheme file) (scheme lazy)
(zilch lib hash) (zilch nix daemon) (zilch nix drv) (zilch nix path)
(zilch nix hash)
(zilch planner step)
@ -21,6 +21,7 @@
store-path-for-text store-path-for-fod store-path-for-drv
store-path-for-impure-drv store-path-for-ca-drv store-path-for-ca-drv*
store-path-realised store-path-open
store-path-devirtualise
drv-resolve-ca
@ -241,9 +242,7 @@
(replace-placeholder placeholder replacement (+ index (string-length replacement))))
(> start-index 0)))
(define context-to-build '())
(define drv-output-map #f)
(define placeholders-to-build '())
(define added-sources '())
(for-each
(lambda (drv-and-outputs)
@ -254,11 +253,12 @@
(lambda (output)
(define placeholder (derivation-output-path (cdr (assoc output (derivation-outputs drv)))))
(define new-path (cdr (assoc output ca-drv)))
(replace-placeholder placeholder new-path 0))
(when (replace-placeholder placeholder new-path 0)
(set! added-sources (cons new-path added-sources))))
(cdr drv-and-outputs))))
drv-context)
path)
(values path added-sources))
(define (zexp-ctx-has-placeholder drv-context)
(if (null? drv-context)
@ -498,22 +498,45 @@
(pending-item-resolved-paths (rewrite-ca-stack drv))
#f))
(define (store-path-realised path)
(define ctx (zexp-unwrap (zexp (zexp-unquote path))))
(define (devirtualise-inner zexpr)
(define ctx (zexp-unwrap (zexp (zexp-unquote zexpr))))
(define val (zexp-evaluation-value ctx))
(define to-build (list))
(define drvs '())
(define srcs (zexp-evaluation-srcs ctx))
(for-each
(lambda (drv-and-outputs)
(unless (drv-is-ca (car drv-and-outputs))
(for-each
(lambda (o)
(set! to-build (cons (string-append (derivation-path (car drv-and-outputs)) "!" o) to-build)))
(cdr drv-and-outputs))))
(set! drvs (cons drv-and-outputs drvs))))
(zexp-evaluation-drvs ctx))
(if (string? val)
(set! val (resolve-upstream-output-placeholders val (zexp-evaluation-drvs ctx)))
(let-values (((new-val new-srcs) (resolve-upstream-output-placeholders val (zexp-evaluation-drvs ctx))))
(set! val new-val)
(set! srcs (append new-srcs srcs)))
(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-devirtualise: expression has dependencies on placeholder context, but isn't a string" (list zexpr val))))
(list val drvs srcs))
(define (store-path-devirtualise zexpr)
(define inner (delay (devirtualise-inner zexpr)))
(make-zexp
(lambda ()
(define processed (force inner))
(zexp-context-register-items (list-ref processed 1) (list-ref processed 2))
(car processed))
(lambda (out)
(fprintf out "#<devirtualised ~S>" zexpr))))
(define (store-path-realised path)
(define devirt (devirtualise-inner path))
(define to-build (list))
(for-each
(lambda (drv-and-outputs)
(for-each
(lambda (o)
(set! to-build (cons (string-append (derivation-path (car drv-and-outputs)) "!" o) to-build)))
(cdr drv-and-outputs)))
(list-ref devirt 1))
(define val (car devirt))
(when (and (string? val) (not (file-exists? val)) (not (null? to-build)))
(daemon-wop-build-paths (*daemon*) (list->vector to-build)))
val)