X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=f99f24eda888d7a066bc80ec280ecf55e7df7620;hb=66cff1e1319861c080d563359afea284614b3a7f;hp=b312c758966563b60630b15cfb5114474a84b6b0;hpb=cb83aa22932bf4b9bc74ac6f0fcd91db1702ad33;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index b312c75..f99f24e 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -37,7 +37,6 @@ (defvar *flame-on-necessarily-undefined-function* nil) (defvar *check-consistency* nil) -(defvar *all-components*) ;;; Set to NIL to disable loop analysis for register allocation. (defvar *loop-analyze* t) @@ -117,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 @@ -975,10 +986,19 @@ (debug-name 'initial-component name)) (setf (component-kind component) :initial) (let* ((locall-fun (let ((*allow-instrumenting* t)) - (apply #'ir1-convert-lambdalike - definition - (list :source-name name)))) - (debug-name (debug-name 'tl-xep name)) + (funcall #'ir1-convert-lambdalike + definition + :source-name 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 + ;; real function (via CONVERT-CALL / PROPAGATE-TO-ARGS). + ;; -- JES, 2007-02-27 + (*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))) @@ -986,6 +1006,7 @@ (assert-global-function-definition-type name locall-fun)) (setf (functional-entry-fun fun) locall-fun (functional-kind fun) :external + (functional-has-external-references-p locall-fun) t (functional-has-external-references-p fun) t) fun))) @@ -1015,6 +1036,7 @@ :policy *policy* :handled-conditions *handled-conditions* :disabled-package-locks *disabled-package-locks*)) + (*compiler-sset-counter* 0) (fun (make-functional-from-toplevel-lambda lambda-expression :name name :path path))) @@ -1029,14 +1051,10 @@ (locall-analyze-clambdas-until-done (list fun)) - (multiple-value-bind (components-from-dfo top-components hairy-top) - (find-initial-dfo (list fun)) - (declare (ignore hairy-top)) - - (let ((*all-components* (append components-from-dfo top-components))) - (dolist (component-from-dfo components-from-dfo) - (compile-component component-from-dfo) - (replace-toplevel-xeps component-from-dfo))) + (let ((components-from-dfo (find-initial-dfo (list fun)))) + (dolist (component-from-dfo components-from-dfo) + (compile-component component-from-dfo) + (replace-toplevel-xeps component-from-dfo)) (let ((entry-table (etypecase *compile-object* (fasl-output (fasl-output-entry-table @@ -1309,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))) @@ -1388,10 +1406,10 @@ (maybe-mumble "IDFO ") (multiple-value-bind (components top-components hairy-top) (find-initial-dfo lambdas) - (let ((*all-components* (append components top-components))) + (let ((all-components (append components top-components))) (when *check-consistency* (maybe-mumble "[check]~%") - (check-ir1-consistency *all-components*)) + (check-ir1-consistency all-components)) (dolist (component (append hairy-top top-components)) (pre-physenv-analyze-toplevel component)) @@ -1402,7 +1420,7 @@ (when *check-consistency* (maybe-mumble "[check]~%") - (check-ir1-consistency *all-components*)) + (check-ir1-consistency all-components)) (if load-time-value-p (compile-load-time-value-lambda lambdas) @@ -1472,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)) @@ -1497,6 +1517,7 @@ ;; and it's not obvious whether the rebinding to itself is ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*. (*info-environment* *info-environment*) + (*compiler-sset-counter* 0) (*gensym-counter* 0)) (handler-case (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler)) @@ -1506,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 @@ -1518,10 +1552,11 @@ ;; 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* "~@" condition)) + (finish-output *error-output*) (values nil t t))))) ;;; Return a pathname for the named file. The file must exist.