fix: propagate pipeline-native failures

packages/compile/tests/compiler-tests.lisp

@@ -122,10 +122,15 @@
 
 ;;; Error Handling Tests
 
-(it-sequential "compile-error-conditions"
-  (handler-case (run-string "x") (error () nil))
-  (handler-case (compile-string "(if 1 2)") (error () nil))
-  (handler-case (compile-string "(+ 1)") (error () nil)))
+(it-sequential "compile-error-conditions-propagate-with-details"
+  (dolist (source '("x" "(if 1 2 3 4)"))
+    (let ((message nil))
+      (handler-case
+          (compile-string source)
+        (error (condition)
+          (setf message (princ-to-string condition))))
+      (expect message :to-be-truthy)
+      (expect message :to-be-truthy))))
 
 ;;; Integration Tests
 

packages/compile/tests/pipeline-native-io-tests.lisp

@@ -6,6 +6,39 @@
 
 (in-package :cl-cc/test)
 
+(it-sequential "pipeline-native-helper-failure-is-not-swallowed"
+  (let ((message nil))
+    (with-replaced-function (uiop:run-program
+                             (lambda (&rest args)
+                               (declare (ignore args))
+                               (error "injected native helper failure")))
+      (handler-case
+          (cl-cc::%run-short-native-command '("codesign" "-s" "-" "output"))
+        (error (condition)
+          (setf message (princ-to-string condition)))))
+    (expect (search "injected native helper failure" message) :to-be-truthy)))
+
+(it-sequential "pipeline-native-relocation-failure-is-not-swallowed"
+  (let ((message nil))
+    (with-replaced-function (cl-cc/codegen::program-reloc-entries
+                             (lambda (&rest args)
+                               (declare (ignore args))
+                               (error "injected relocation failure")))
+      (handler-case
+          (cl-cc::%native-relocation-entries :program :elf)
+        (error (condition)
+          (setf message (princ-to-string condition)))))
+    (expect (search "injected relocation failure" message) :to-be-truthy)))
+
+(it-sequential "pipeline-native-stdlib-cache-is-not-fresh-without-source-dates"
+  (uiop:with-temporary-file (:pathname cache :keep t)
+    (with-open-file (stream cache :direction :output :if-exists :supersede)
+      (write-line "cache" stream))
+    (with-replaced-function (cl-cc/pipeline::%stdlib-source-file-paths
+                             (lambda () nil))
+      (expect (cl-cc/pipeline::%stdlib-cache-fresh-p cache) :to-be-falsy))
+    (ignore-errors (delete-file cache))))
+
 (defmacro with-native-cache-stubs ((&key cache-path) &body body)
   "Stub cache-related native helper calls for routing/cache tests."
   `(with-replaced-function (cl-cc::%compile-cache-key

packages/pipeline/src/package.lisp

@@ -146,6 +146,7 @@
    #:%build-stdlib-expanded-cache
    #:%copy-snapshot-ht
    #:%write-native-binary
+   #:%native-relocation-entries
    #:%compile-cache-key
    #:%compile-cache-path
    #:%compile-native-expression

packages/pipeline/src/pipeline-native.lisp

@@ -23,13 +23,25 @@ The direct VM-to-codegen path remains the fallback and the default.")
 
 (defun %run-short-native-command (argv)
   "Run a short external helper command with an explicit timeout.
-Returns NIL on timeout or command failure so native compilation can continue
-without hanging forever on platform utility calls like chmod."
+Signals an error on timeout or command failure so native compilation cannot
+report an unsigned or non-executable artifact as successful."
   (handler-case
       (sb-ext:with-timeout *native-command-timeout-seconds*
-        (uiop:run-program argv :ignore-error-status t))
-    (sb-ext:timeout () nil)
-    (error () nil)))
+        (uiop:run-program argv :ignore-error-status nil))
+    (sb-ext:timeout ()
+      (error "Native helper timed out: ~{~A~^ ~}" argv))
+    (error (condition)
+      (error "Native helper failed (~{~A~^ ~}): ~A" argv condition))))
+
+(defun %native-relocation-entries (program format)
+  "Return PROGRAM relocation entries required by FORMAT.
+Mach-O currently embeds its own builder relocations. Older pinned code generators
+may not expose relocation metadata yet; those backends continue with an empty
+relocation list until their pin is advanced."
+  (unless (eq format :mach-o)
+    (let ((accessor 'cl-cc/codegen::program-reloc-entries))
+      (when (fboundp accessor)
+        (funcall accessor program)))))
 
 (defun %native-host-os ()
   "Return a keyword identifying the host operating system.
@@ -588,7 +600,8 @@ Returns the output file path on success."
                                        :strict-no-alloc strict-no-alloc
                                        :target-os effective-target-os))
          (compile-opts (%strip-internal-opts opts))
-         (result (%compile-native-source source native-target language compile-opts))
+         (result (%ensure-compilation-success
+                  (%compile-native-source source native-target language compile-opts)))
             (program (maybe-pipeline-bolt-optimize-program
                       (pipeline-reorder-functions
                        (%maybe-route-program-through-mir
@@ -611,10 +624,7 @@ Returns the output file path on success."
                               (cl-cc/codegen:normalize-x86-64-eh-model
                                (or (getf opts :eh-model) cl-cc/codegen::*eh-model*))))
                          (%native-code-bytes-for-arch arch program opts)))
-         (compilation-result (compilation-result-program result))
-         (reloc-entries (and compilation-result
-                             (ignore-errors
-                              (cl-cc/codegen::program-reloc-entries compilation-result)))))
+         (reloc-entries (%native-relocation-entries program binary-format)))
     (%write-native-output code-bytes reloc-entries output-file
                           :format binary-format :arch arch
                           :compress (getf opts :compress))))
@@ -757,8 +767,9 @@ TARGET-OS is :DARWIN (default on macOS), :LINUX, or :WINDOWS. When NIL, auto-det
           output)
         (let* ((native-target (%native-target-for-arch arch))
                (compile-opts (%strip-internal-opts opts))
-               (result (%compile-native-file-source source native-target effective-language compile-opts))
-                  (program (maybe-pipeline-bolt-optimize-program
+               (raw-result (%compile-native-file-source source native-target effective-language compile-opts))
+               (result (%ensure-compilation-success raw-result))
+               (program (maybe-pipeline-bolt-optimize-program
                             (pipeline-reorder-functions
                              (%maybe-route-program-through-mir
                               (compilation-result-program result) arch opts))
@@ -780,7 +791,9 @@ TARGET-OS is :DARWIN (default on macOS), :LINUX, or :WINDOWS. When NIL, auto-det
                                     (cl-cc/codegen:normalize-x86-64-eh-model
                                      (or (getf opts :eh-model) cl-cc/codegen::*eh-model*))))
                                (%native-code-bytes-for-arch arch program opts))))
-          (%write-native-output code-bytes nil output
+          (%write-native-output code-bytes
+                               (%native-relocation-entries program binary-format)
+                               output
                                :format binary-format :arch arch
                                :compress (getf opts :compress))
           (%copy-file-bytes output cache-path)

packages/pipeline/src/pipeline-stdlib.lisp

@@ -107,29 +107,36 @@ SETF places while isolating per-source typed defstruct accessors.")
 
 (defun %stdlib-source-file-paths ()
   "Return known source files that contribute to *STANDARD-LIBRARY-SOURCE*."
+  ;; The disk cache is optional, but an unknown source location must invalidate
+  ;; it rather than making an old cache appear fresh.
   (let ((base (ignore-errors
                 (asdf:system-relative-pathname :cl-cc-stdlib #P"src/"))))
-    (remove-if-not #'probe-file
-                   (when base
-                     (mapcar (lambda (name) (merge-pathnames name base))
-                             '("stdlib-source-core.lisp"
-                               "stdlib-source.lisp"
-                               "stdlib-source-ext.lisp"
-                               "stdlib-source-clos.lisp"))))))
+    (when base
+      (let ((paths (mapcar (lambda (name) (merge-pathnames name base))
+                           '("stdlib-source-core.lisp"
+                             "stdlib-source.lisp"
+                             "stdlib-source-ext.lisp"
+                             "stdlib-source-clos.lisp"))))
+        (and (every #'probe-file paths) paths)))))
 
 (defun %stdlib-source-newest-write-date ()
-  "Return the newest write date among stdlib source files, or 0 if unknown."
-  (loop for path in (%stdlib-source-file-paths)
-        for date = (ignore-errors (file-write-date path))
-        when date maximize date into newest
-        finally (return (or newest 0))))
+  "Return the newest write date, or NIL when any source date is unknown."
+  (let ((paths (%stdlib-source-file-paths)))
+    (when paths
+      (loop for path in paths
+            for date = (ignore-errors (file-write-date path))
+            when (null date) do (return-from %stdlib-source-newest-write-date nil)
+            maximize date into newest
+            finally (return newest)))))
 
 (defun %stdlib-cache-fresh-p (cache-path)
   "Return T when CACHE-PATH exists and is newer than all stdlib source files."
   (let ((cache-date (and (probe-file cache-path)
                          (ignore-errors (file-write-date cache-path)))))
-    (and cache-date
-         (>= cache-date (%stdlib-source-newest-write-date)))))
+    (let ((source-date (%stdlib-source-newest-write-date)))
+      (and cache-date
+           source-date
+           (>= cache-date source-date)))))
 
 (defun %stdlib-cache-payload-valid-p (payload)
   "Return T when PAYLOAD is a readable stdlib cache payload."

packages/pipeline/src/pipeline.lisp

@@ -378,6 +378,17 @@ takes the top-level path) caught correctly."
                  (cl-cc/compile:compilation-result-vm-instructions result)))
           result))))
 
+(defun %ensure-compilation-success (result &key (ignore-form-index-below 0))
+  "Signal recorded top-level compilation errors before exposing RESULT."
+  (let ((errors (remove-if
+                 (lambda (entry)
+                   (< (getf entry :form-index) ignore-form-index-below))
+                 (cl-cc/compile:compilation-result-errors result))))
+    (when errors
+      (error "Compilation failed:~%~{~A~^~%~}"
+             (mapcar #'princ-to-string errors))))
+  result)
+
 ;;; ─────────────────────────────────────────────────────────────────────────
 ;;; Language-level parsing
 ;;; ─────────────────────────────────────────────────────────────────────────
@@ -600,6 +611,7 @@ top-level, and optimization stages."
                               (apply #'compile-toplevel-forms
                                      forms
                                      (%opts->compile-kwargs opts)))))))))
+      (%ensure-compilation-success result)
       (%pgo-apply-type-feedback-to-result result opts)
       (setf (cl-cc/vm:vm-program-compilation-tier
              (cl-cc/compile:compilation-result-program result))
@@ -670,7 +682,7 @@ arguments are forwarded to the expression, top-level, and optimization stages."
            (*enable-cps-vm-primary-path* nil)
            (stdlib-forms (get-stdlib-forms))
            (all-forms (append stdlib-forms forms))
-            (result (%call-with-source-file-macro-eval
+           (result (%call-with-source-file-macro-eval
                      source-file
                      (lambda ()
                         (%call-with-tiered-optimizer-policy
@@ -679,6 +691,9 @@ arguments are forwarded to the expression, top-level, and optimization stages."
                            (apply #'compile-toplevel-forms
                                   all-forms
                                   (%opts->compile-kwargs opts))))))))
+      (%ensure-compilation-success
+       result
+       :ignore-form-index-below (length stdlib-forms))
       (setf (cl-cc/compile:compilation-result-pgo-counter-plan result)
             (%build-pgo-counter-plan-from-instructions
              (cl-cc/compile:compilation-result-vm-instructions result)))