diff --git a/packages/compile/tests/compiler-tests.lisp b/packages/compile/tests/compiler-tests.lisp index 3685fd07..09511870 100644 --- a/packages/compile/tests/compiler-tests.lisp +++ b/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 diff --git a/packages/compile/tests/pipeline-native-io-tests.lisp b/packages/compile/tests/pipeline-native-io-tests.lisp index 4de47db8..61467bf1 100644 --- a/packages/compile/tests/pipeline-native-io-tests.lisp +++ b/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 diff --git a/packages/pipeline/src/package.lisp b/packages/pipeline/src/package.lisp index 4c9b4b04..97ad6cf1 100644 --- a/packages/pipeline/src/package.lisp +++ b/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 diff --git a/packages/pipeline/src/pipeline-native.lisp b/packages/pipeline/src/pipeline-native.lisp index 55da41c9..d7b9e299 100644 --- a/packages/pipeline/src/pipeline-native.lisp +++ b/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) diff --git a/packages/pipeline/src/pipeline-stdlib.lisp b/packages/pipeline/src/pipeline-stdlib.lisp index 54dd3144..0e9f4184 100644 --- a/packages/pipeline/src/pipeline-stdlib.lisp +++ b/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." diff --git a/packages/pipeline/src/pipeline.lisp b/packages/pipeline/src/pipeline.lisp index 9e9d56c9..552e3c66 100644 --- a/packages/pipeline/src/pipeline.lisp +++ b/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)))