#!+sb-show *compiler-trace-output*
*last-source-context* *last-original-source*
*last-source-form* *last-format-string* *last-format-args*
- *last-message-count* *lexenv* *fun-names-in-this-file*
+ *last-message-count* *last-error-context*
+ *lexenv* *fun-names-in-this-file*
*allow-instrumenting*))
;;; Whether call of a function which cannot be defined causes a full
(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)
(defvar *compile-object* nil)
(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
(let* ((*component-being-compiled* component))
+ ;; Record xref information before optimization. This way the
+ ;; stored xref data reflects the real source as closely as
+ ;; possible.
+ (record-component-xrefs component)
+
(ir1-phases component)
(when *loop-analyze*
;;; 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 file
+ :untruename (merge-pathnames file)
:external-format external-format
:write-date (file-write-date file))))
;;; *TOPLEVEL-LAMBDAS* instead.
(defun convert-and-maybe-compile (form path)
(declare (list path))
- (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))
+ (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)))
;;; Macroexpand FORM in the current environment with an error handler.
;;; We only expand one level, so that we retain all the intervening
(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))))
+ (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 'tl-xep name))))
+ :debug-name debug-name)))
(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)))
: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)))
(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
;; sequence of steps in ANSI's "3.2.3.1 Processing of
;; Top Level Forms".
#-sb-xc-host
- (let ((expanded (preprocessor-macroexpand-1 form)))
+ (let ((expanded
+ (let ((*current-path* path))
+ (preprocessor-macroexpand-1 form))))
(cond ((eq expanded form)
(when compile-time-too
(eval-in-lexenv form *lexenv*))
(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)))
(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))
(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)
(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))
;; 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))
(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)))))
;;; -- WHN 2000-12-09
(defun sb!xc:compile-file-pathname (input-file
&key
- (output-file (cfp-output-file-default
- input-file))
+ (output-file nil output-file-p)
&allow-other-keys)
#!+sb-doc
"Return a pathname describing what file COMPILE-FILE would write to given
these arguments."
- (merge-pathnames output-file (merge-pathnames input-file)))
+ (if output-file-p
+ (merge-pathnames output-file (cfp-output-file-default input-file))
+ (cfp-output-file-default input-file)))
\f
;;;; MAKE-LOAD-FORM stuff
(:ignore-it
nil)
(t
- (when (fasl-constant-already-dumped-p constant *compile-object*)
- (return-from emit-make-load-form nil))
(let* ((name (write-to-string constant :level 1 :length 2))
(info (if init-form
(list constant name init-form)
projects / sbcl.git / blobdiff