X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=14c3b43fb9a2466b6ac936e6420e855c95d1e276;hb=e3113504fca73ebd1b992930315386d9d3ae5d18;hp=b312c758966563b60630b15cfb5114474a84b6b0;hpb=cb83aa22932bf4b9bc74ac6f0fcd91db1702ad33;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index b312c75..14c3b43 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 @@ -165,7 +176,7 @@ (*compiler-note-count* 0) (*undefined-warnings* nil) (*in-compilation-unit* t)) - (sb!thread:with-recursive-lock (*big-compiler-lock*) + (with-world-lock () (handler-bind ((parse-unknown-type (lambda (c) (note-undefined-reference @@ -376,10 +387,12 @@ (defun ir1-phases (component) (declare (type component component)) (aver-live-component component) - (let ((*constraint-number* 0) + (let ((*constraint-universe* (make-array 64 ; arbitrary, but don't + ;make this 0. + :fill-pointer 0 :adjustable t)) (loop-count 1) (*delayed-ir1-transforms* nil)) - (declare (special *constraint-number* *delayed-ir1-transforms*)) + (declare (special *constraint-universe* *delayed-ir1-transforms*)) (loop (ir1-optimize-until-done component) (when (or (component-new-functionals component) @@ -709,10 +722,15 @@ ;;; A FILE-INFO structure holds all the source information for a ;;; given file. -(def!struct (file-info (:copier nil)) +(def!struct (file-info + (:copier nil) + #-no-ansi-print-object + (:print-object (lambda (s stream) + (print-unreadable-object (s stream :type t) + (princ (file-info-name s) stream))))) ;; If a file, the truename of the corresponding source file. If from ;; a Lisp form, :LISP. If from a stream, :STREAM. - (name (missing-arg) :type (or pathname (member :lisp :stream))) + (name (missing-arg) :type (or pathname (eql :lisp))) ;; the external format that we'll call OPEN with, if NAME is a file. (external-format nil) ;; the defaulted, but not necessarily absolute file name (i.e. prior @@ -745,29 +763,39 @@ (file-info nil :type (or file-info null)) ;; the stream that we are using to read the FILE-INFO, or NIL if ;; no stream has been opened yet - (stream nil :type (or stream null))) + (stream nil :type (or stream null)) + ;; if the current compilation is recursive (e.g., due to EVAL-WHEN + ;; processing at compile-time), the invoking compilation's + ;; source-info. + (parent nil :type (or source-info null))) ;;; Given a pathname, return a SOURCE-INFO structure. (defun make-file-source-info (file external-format) - (let ((file-info (make-file-info :name (truename file) - :untruename (merge-pathnames file) - :external-format external-format - :write-date (file-write-date file)))) - - (make-source-info :file-info file-info))) + (make-source-info + :file-info (make-file-info :name (truename file) + :untruename (merge-pathnames file) + :external-format external-format + :write-date (file-write-date file)))) ;;; Return a SOURCE-INFO to describe the incremental compilation of FORM. -(defun make-lisp-source-info (form) - (make-source-info :start-time (get-universal-time) - :file-info (make-file-info :name :lisp - :forms (vector form) - :positions '#(0)))) - -;;; Return a SOURCE-INFO which will read from STREAM. -(defun make-stream-source-info (stream) - (let ((file-info (make-file-info :name :stream))) - (make-source-info :file-info file-info - :stream stream))) +(defun make-lisp-source-info (form &key parent) + (make-source-info + :file-info (make-file-info :name :lisp + :forms (vector form) + :positions '#(0)) + :parent parent)) + +;;; Walk up the SOURCE-INFO list until we either reach a SOURCE-INFO +;;; with no parent (e.g., from a REPL evaluation) or until we reach a +;;; SOURCE-INFO whose FILE-INFO denotes a file. +(defun get-toplevelish-file-info (&optional (source-info *source-info*)) + (if source-info + (do* ((sinfo source-info (source-info-parent sinfo)) + (finfo (source-info-file-info sinfo) + (source-info-file-info sinfo))) + ((or (not (source-info-p (source-info-parent sinfo))) + (pathnamep (file-info-name finfo))) + finfo)))) ;;; Return a form read from STREAM; or for EOF use the trick, ;;; popularized by Kent Pitman, of returning STREAM itself. If an @@ -824,24 +852,37 @@ (setf (source-info-stream info) nil) (values)) +;;; Loop over FORMS retrieved from INFO. Used by COMPILE-FILE and +;;; LOAD when loading from a FILE-STREAM associated with a source +;;; file. +(defmacro do-forms-from-info (((form &rest keys) info) + &body body) + (aver (symbolp form)) + (once-only ((info info)) + `(let ((*source-info* ,info)) + (loop (destructuring-bind (,form &key ,@keys &allow-other-keys) + (let* ((file-info (source-info-file-info ,info)) + (stream (get-source-stream ,info)) + (pos (file-position stream)) + (form (read-for-compile-file stream pos))) + (if (eq form stream) ; i.e., if EOF + (return) + (let* ((forms (file-info-forms file-info)) + (current-idx (+ (fill-pointer forms) + (file-info-source-root + file-info)))) + (vector-push-extend form forms) + (vector-push-extend pos (file-info-positions + file-info)) + (list form :current-index current-idx)))) + ,@body))))) + ;;; Read and compile the source file. (defun sub-sub-compile-file (info) - (let* ((file-info (source-info-file-info info)) - (stream (get-source-stream info))) - (loop - (let* ((pos (file-position stream)) - (form (read-for-compile-file stream pos))) - (if (eq form stream) ; i.e., if EOF - (return) - (let* ((forms (file-info-forms file-info)) - (current-idx (+ (fill-pointer forms) - (file-info-source-root file-info)))) - (vector-push-extend form forms) - (vector-push-extend pos (file-info-positions file-info)) - (find-source-paths form current-idx) - (process-toplevel-form form - `(original-source-start 0 ,current-idx) - nil))))))) + (do-forms-from-info ((form current-index) info) + (find-source-paths form current-index) + (process-toplevel-form + form `(original-source-start 0 ,current-index) nil))) ;;; Return the INDEX'th source form read from INFO and the position ;;; where it was read. @@ -859,19 +900,21 @@ ;;; *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 @@ -960,7 +1003,7 @@ (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 @@ -970,22 +1013,31 @@ (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)) - (apply #'ir1-convert-lambdalike - definition - (list :source-name name)))) - (debug-name (debug-name 'tl-xep name)) + (funcall #'ir1-convert-lambdalike + 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 + ;; 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))) + :source-name source-name + :debug-name (debug-name 'tl-xep debug-name-tail) + :system-lambda t))) (when name (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 +1067,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 +1082,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 @@ -1132,7 +1181,7 @@ (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 @@ -1309,7 +1358,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 +1437,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 +1451,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) @@ -1464,7 +1513,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)) @@ -1472,18 +1521,19 @@ (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)) (*block-compile* *block-compile-arg*) - (*source-info* info) (*toplevel-lambdas* ()) (*fun-names-in-this-file* ()) (*allow-instrumenting* nil) (*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) @@ -1497,6 +1547,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 +1557,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,11 +1582,12 @@ ;; 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)) - (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) @@ -1631,7 +1696,7 @@ SPEED and COMPILATION-SPEED optimization values, and the |# (let* ((fasl-output nil) (output-file-name nil) - (compile-won nil) + (abort-p t) (warnings-p nil) (failure-p t) ; T in case error keeps this from being set later (input-pathname (verify-source-file input-file)) @@ -1662,31 +1727,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))) @@ -1774,7 +1842,7 @@ SPEED and COMPILATION-SPEED optimization values, and the (defvar *constants-being-created* nil) (defvar *constants-created-since-last-init* nil) ;;; FIXME: Shouldn't these^ variables be unbound outside LET forms? -(defun emit-make-load-form (constant) +(defun emit-make-load-form (constant &optional (name nil namep)) (aver (fasl-output-p *compile-object*)) (unless (or (fasl-constant-already-dumped-p constant *compile-object*) ;; KLUDGE: This special hack is because I was too lazy @@ -1790,10 +1858,14 @@ SPEED and COMPILATION-SPEED optimization values, and the (throw constant t)) (throw 'pending-init circular-ref))) (multiple-value-bind (creation-form init-form) - (handler-case - (sb!xc:make-load-form constant (make-null-lexenv)) - (error (condition) - (compiler-error condition))) + (if namep + ;; If the constant is a reference to a named constant, we can + ;; just use SYMBOL-VALUE during LOAD. + (values `(symbol-value ',name) nil) + (handler-case + (sb!xc:make-load-form constant (make-null-lexenv)) + (error (condition) + (compiler-error condition)))) (case creation-form (:sb-just-dump-it-normally (fasl-validate-structure constant *compile-object*)