From be1b4c3792e722a74be92dc2aee9e565ad992895 Mon Sep 17 00:00:00 2001
From: Puck Meerburg <puck@puckipedia.com>
Date: Thu, 1 May 2025 13:20:05 +0000
Subject: [PATCH] (zilch lang ninja build): improve build environment + setup
 times

Turns out generating one full VFS for every single build step is really
expensive.
---
 lang/ninja/src/build.sld | 33 ++++++++++++++++++++++++++-------
 1 file changed, 26 insertions(+), 7 deletions(-)

diff --git a/lang/ninja/src/build.sld b/lang/ninja/src/build.sld
index 29767f2..8fdcc21 100644
--- a/lang/ninja/src/build.sld
+++ b/lang/ninja/src/build.sld
@@ -4,6 +4,7 @@
   (zilch file) (zilch magic) (scheme char)
   (zilch nix drv) (zilch nix path)
   (zilch nixpkgs) (zilch zexpr) (zilch vfs)
+  (chicken format)
   (srfi 128) (srfi 146) (srfi 152)
   (zilch lang ninja))
 
@@ -41,9 +42,10 @@
       (string-map (lambda (c) (if (is-valid-store-path-char c) c #\-)) (if (> (string-length str) 211) (string-copy str 0 211) str))))
 
 
-  (define (derivation-for-edge environment vfs relative-to-root edges current-edge)
+  (define (derivation-for-edge environment vfs-store-path relative-to-root edges current-edge)
     (define resolved (build-edge-resolved current-edge))
     (when (build-rule-rspfile resolved) (error "rspfile not yet supported" current-edge))
+    (define copy-input-files "")
     (define (append-file path)
       (define input-file (mapping-ref edges path (lambda () (mapping-ref/default edges (normalize-path path) #f))))
 
@@ -51,16 +53,25 @@
       (unless (eq? input-file 'base)
         (if input-file
           ; This file is produced by another build edge. Add it to our input vfs.
-          (set! vfs (vfs-append-file vfs (normalize-path path) (force input-file)))
-          (error "Path doesn't exist as build edge" path))))
+          (let ((prev-copy-input-files copy-input-files))
+            (set! copy-input-files #~,(string-append #$prev-copy-input-files "\n" "$COREUTILS/mkdir -p bdir/" relative-to-root "/$($COREUTILS/dirname " path "); $COREUTILS/cp -rf " #$(force input-file) " bdir/" relative-to-root "/" path))); (set! vfs (vfs-append-file vfs (normalize-path path) (force input-file)))
+          (if (string-prefix? "/nix/store" path)
+              (fprintf (current-error-port) "Path doesn't exist as build edge: ~S\n" path)
+              (error "Path doesn't exist as build edge" path))))
 
     ; Add the inputs, implicit dependencies, _and_ order-only dependencies to our vfs.
     (for-each append-file (build-edge-inputs current-edge))
     (for-each append-file (build-edge-implicit-dependencies current-edge))
     (for-each append-file (build-edge-order-only-dependencies current-edge))
 
+    ; Create parent directories for each output (TODO: implicit outputs?)
+    (for-each
+      (lambda (path)
+        (define prev-copy-input-files copy-input-files)
+        (set! copy-input-files #~,(string-append #$prev-copy-input-files "\n" "$COREUTILS/mkdir -p bdir/" relative-to-root "/$($COREUTILS/dirname " path ")")))
+      (build-edge-outputs current-edge))
+
     ; Create the VFS.
-    (define input-store-path (vfs-to-store vfs))
     (define command-to-run (build-rule-command resolved))
 
     ; For each output and implicit output, copy them to the derivation's output.
@@ -74,8 +85,10 @@
     ; Run the build rule inside the build environment's vfs. This requires copying the entire VFS over, sadly.
     (define command
       #~,(string-append
-          #$coreutils "/bin/cp -rf --no-preserve=ownership " #$input-store-path " bdir\n"
-          #$coreutils "/bin/chmod ugo+rw -R bdir\ncd bdir/" relative-to-root "\n"
+          #$coreutils "/bin/cp -rf --no-preserve=ownership " #$vfs-store-path " bdir\n"
+          #$coreutils "/bin/chmod ugo+rw -R bdir\n"
+          "(COREUTILS=" #$coreutils "/bin; " #$copy-input-files ")\n"
+          "cd bdir/" relative-to-root "\n"
           "(" command-to-run ") || exit 1\n"
           "COREUTILS=" #$coreutils"/bin\n"
           "$COREUTILS/mkdir " out-placeholder "\n"
@@ -100,6 +113,7 @@
   ;; to be a nixpkgs-style derivation, the same way `nix-shell` works.
   (define (process-ninja-file file vfs environment relative-to)
     (when (or (derivation? environment) (store-path? environment)) (set! environment (environment-for-derivation environment)))
+    (unless (string-suffix? "/" relative-to) (set! relative-to (string-append relative-to "/")))
 
     (define edges (mapping (make-default-comparator)))
 
@@ -107,11 +121,16 @@
     (mapping-for-each
      (lambda (kv path)
        (define path (if (string=? (car kv) "") (cdr kv) (string-append (car kv) "/" (cdr kv))))
+       (cond
+        ((string=? relative-to "") #f)
+        ((string-prefix? relative-to path) (set! path (string-copy path (string-length relative-to))))
+        (else (set! path (string-append "../" path))))
        (set! edges (mapping-set! edges path 'base)))
      (vfs-contents vfs))
+    (define vfs-store-path (vfs-to-store vfs))
     (for-each
      (lambda (edge)
-      (define processed (delay (derivation-for-edge environment vfs relative-to edges edge)))
+      (define processed (delay (derivation-for-edge environment vfs-store-path relative-to edges edge)))
       (for-each (lambda (v) (set! edges (mapping-set! edges v (delay #~,(string-append #$(force processed) "/" v)))))
         (append (build-edge-outputs edge) (build-edge-implicit-outputs edge))))
      (build-file-build-edges file))