X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=7b671c479e936d85d2260256d82bd58226789840;hb=260a9146f02374a9cfbd9deb53283ee493f3729f;hp=168fe6f8656a44520e5ad7d1f7c390e76c17a373;hpb=29f0545ba7ae947489d2d5fab0faa2b499096713;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 168fe6f..7b671c4 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -116,6 +116,18 @@ (declaim (type object *compile-object*)) (defvar *fopcompile-label-counter*) + +;; Used during compilation to map code paths to the matching +;; instrumentation conses. +(defvar *code-coverage-records* nil) +;; Used during compilation to keep track of with source paths have been +;; instrumented in which blocks. +(defvar *code-coverage-blocks* nil) +;; Stores the code coverage instrumentation results. Keys are namestrings, +;; the value is a list of (CONS PATH STATE), where STATE is NIL for +;; a path that has not been visited, and T for one that has. +(defvar *code-coverage-info* (make-hash-table :test 'equal)) + ;;;; WITH-COMPILATION-UNIT and WITH-COMPILATION-VALUES @@ -977,7 +989,9 @@ (funcall #'ir1-convert-lambdalike definition :source-name name))) - (debug-name (debug-name 'tl-xep name)) + (debug-name (debug-name 'tl-xep + (or name + (functional-%source-name locall-fun)))) ;; Convert the XEP using the policy of the real ;; function. Otherwise the wrong policy will be used for ;; deciding whether to type-check the parameters of the @@ -1313,7 +1327,7 @@ (defun compile-load-time-stuff (form for-value) (with-ir1-namespace (let* ((*lexenv* (make-null-lexenv)) - (lambda (ir1-toplevel form *current-path* for-value))) + (lambda (ir1-toplevel form *current-path* for-value nil))) (compile-toplevel (list lambda) t) lambda))) @@ -1468,7 +1482,7 @@ (invoke-restart it)))))))) ;;; Read all forms from INFO and compile them, with output to OBJECT. -;;; Return (VALUES NIL WARNINGS-P FAILURE-P). +;;; Return (VALUES ABORT-P WARNINGS-P FAILURE-P). (defun sub-compile-file (info) (declare (type source-info info)) (let ((*package* (sane-package)) @@ -1476,6 +1490,8 @@ (sb!xc:*compile-file-pathname* nil) ; really bound in (sb!xc:*compile-file-truename* nil) ; SUB-SUB-COMPILE-FILE (*policy* *policy*) + (*code-coverage-records* (make-hash-table :test 'equal)) + (*code-coverage-blocks* (make-hash-table :test 'equal)) (*handled-conditions* *handled-conditions*) (*disabled-package-locks* *disabled-package-locks*) (*lexenv* (make-null-lexenv)) @@ -1487,7 +1503,7 @@ (*compiler-error-bailout* (lambda () (compiler-mumble "~2&; fatal error, aborting compilation~%") - (return-from sub-compile-file (values nil t t)))) + (return-from sub-compile-file (values t t t)))) (*current-path* nil) (*last-source-context* nil) (*last-original-source* nil) @@ -1511,6 +1527,19 @@ (sub-sub-compile-file info) + (unless (zerop (hash-table-count *code-coverage-records*)) + ;; Dump the code coverage records into the fasl. + (fopcompile `(record-code-coverage + ',(namestring *compile-file-pathname*) + ',(let (list) + (maphash (lambda (k v) + (declare (ignore k)) + (push v list)) + *code-coverage-records*) + list)) + nil + nil)) + (finish-block-compilation) (let ((object *compile-object*)) (etypecase object @@ -1527,7 +1556,8 @@ (format *error-output* "~@" condition)) - (values nil t t))))) + (finish-output *error-output*) + (values t t t))))) ;;; Return a pathname for the named file. The file must exist. (defun verify-source-file (pathname-designator) @@ -1636,7 +1666,7 @@ SPEED and COMPILATION-SPEED optimization values, and the |# (let* ((fasl-output nil) (output-file-name nil) - (compile-won nil) + (abort-p nil) (warnings-p nil) (failure-p t) ; T in case error keeps this from being set later (input-pathname (verify-source-file input-file)) @@ -1667,31 +1697,34 @@ SPEED and COMPILATION-SPEED optimization values, and the (when sb!xc:*compile-verbose* (print-compile-start-note source-info)) - (let ((*compile-object* fasl-output) - dummy) - (multiple-value-setq (dummy warnings-p failure-p) - (sub-compile-file source-info))) - (setq compile-won t)) + + (let ((*compile-object* fasl-output)) + (setf (values abort-p warnings-p failure-p) + (sub-compile-file source-info)))) (close-source-info source-info) (when fasl-output - (close-fasl-output fasl-output (not compile-won)) + (close-fasl-output fasl-output abort-p) (setq output-file-name (pathname (fasl-output-stream fasl-output))) - (when (and compile-won sb!xc:*compile-verbose*) + (when (and (not abort-p) sb!xc:*compile-verbose*) (compiler-mumble "~2&; ~A written~%" (namestring output-file-name)))) (when sb!xc:*compile-verbose* - (print-compile-end-note source-info compile-won)) + (print-compile-end-note source-info (not abort-p))) (when *compiler-trace-output* (close *compiler-trace-output*))) - (values (if output-file - ;; Hack around filesystem race condition... - (or (probe-file output-file-name) output-file-name) - nil) + ;; CLHS says that the first value is NIL if the "file could not + ;; be created". We interpret this to mean "a valid fasl could not + ;; be created" -- which can happen if the compilation is aborted + ;; before the whole file has been processed, due to eg. a reader + ;; error. + (values (when (and (not abort-p) output-file) + ;; Hack around filesystem race condition... + (or (probe-file output-file-name) output-file-name)) warnings-p failure-p)))