(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))
+
\f
;;;; WITH-COMPILATION-UNIT and WITH-COMPILATION-VALUES
;;; *TOPLEVEL-LAMBDAS* instead.
(defun convert-and-maybe-compile (form path)
(declare (list path))
- (if (fopcompilable-p form)
- (let ((*fopcompile-label-counter* 0))
- (fopcompile form path nil))
- (let* ((*top-level-form-noted* (note-top-level-form form t))
- (*lexenv* (make-lexenv
- :policy *policy*
- :handled-conditions *handled-conditions*
- :disabled-package-locks *disabled-package-locks*))
- (tll (ir1-toplevel form path nil)))
- (if (eq *block-compile* t)
- (push tll *toplevel-lambdas*)
- (compile-toplevel (list tll) nil))
- nil)))
+ (let ((*top-level-form-noted* (note-top-level-form form t)))
+ ;; Don't bother to compile simple objects that just sit there.
+ (when (and form (or (symbolp form) (consp form)))
+ (if (fopcompilable-p form)
+ (let ((*fopcompile-label-counter* 0))
+ (fopcompile form path nil))
+ (let ((*lexenv* (make-lexenv
+ :policy *policy*
+ :handled-conditions *handled-conditions*
+ :disabled-package-locks *disabled-package-locks*))
+ (tll (ir1-toplevel form path nil)))
+ (if (eq *block-compile* t)
+ (push tll *toplevel-lambdas*)
+ (compile-toplevel (list tll) nil))
+ nil)))))
;;; Macroexpand FORM in the current environment with an error handler.
;;; We only expand one level, so that we retain all the intervening
(maybe-frob (optional-dispatch-main-entry f)))
result))))
-(defun make-functional-from-toplevel-lambda (definition
+(defun make-functional-from-toplevel-lambda (lambda-expression
&key
name
(path
(missing-arg)))
(let* ((*current-path* path)
(component (make-empty-component))
- (*current-component* component))
- (setf (component-name component)
- (debug-name 'initial-component name))
- (setf (component-kind component) :initial)
+ (*current-component* component)
+ (debug-name-tail (or name (name-lambdalike lambda-expression)))
+ (source-name (or name '.anonymous.)))
+ (setf (component-name component) (debug-name 'initial-component debug-name-tail)
+ (component-kind component) :initial)
(let* ((locall-fun (let ((*allow-instrumenting* t))
(funcall #'ir1-convert-lambdalike
- definition
- :source-name name)))
- (debug-name (debug-name 'tl-xep name))
+ lambda-expression
+ :source-name source-name)))
;; 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
(*lexenv* (make-lexenv :policy (lexenv-policy
(functional-lexenv locall-fun))))
(fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
- :source-name (or name '.anonymous.)
- :debug-name debug-name)))
+ :source-name source-name
+ :debug-name (debug-name 'tl-xep debug-name-tail))))
(when name
(assert-global-function-definition-type name locall-fun))
(setf (functional-entry-fun fun) locall-fun
(declare (list path))
(catch 'process-toplevel-form-error-abort
- (let* ((path (or (gethash form *source-paths*) (cons form path)))
+ (let* ((path (or (get-source-path form) (cons form path)))
(*compiler-error-bailout*
(lambda (&optional condition)
(convert-and-maybe-compile
(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)))
(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))
(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))
(*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)
(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
;; the input file.
(fatal-compiler-error (condition)
(signal condition)
- (when *compile-verbose*
- (format *standard-output*
+ (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
+ (format *error-output*
"~@<compilation aborted because of fatal error: ~2I~_~A~:>"
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)
|#
(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))
(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)))
\f