;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp?
(declaim (special *constants* *free-vars* *component-being-compiled*
- *code-vector* *next-location* *result-fixups*
- *free-funs* *source-paths*
- *seen-blocks* *seen-funs* *list-conflicts-table*
- *continuation-number* *continuation-numbers*
- *number-continuations* *tn-id* *tn-ids* *id-tns*
- *label-ids* *label-id* *id-labels*
- *undefined-warnings* *compiler-error-count*
- *compiler-warning-count* *compiler-style-warning-count*
- *compiler-note-count*
- *compiler-error-bailout*
- #!+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*
+ *free-funs* *source-paths*
+ *continuation-number* *continuation-numbers*
+ *number-continuations* *tn-id* *tn-ids* *id-tns*
+ *label-ids* *label-id* *id-labels*
+ *undefined-warnings* *compiler-error-count*
+ *compiler-warning-count* *compiler-style-warning-count*
+ *compiler-note-count*
+ *compiler-error-bailout*
+ #!+sb-show *compiler-trace-output*
+ *last-source-context* *last-original-source*
+ *last-source-form* *last-format-string* *last-format-args*
+ *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
+;;; Whether reference to a thing which cannot be defined causes a full
;;; warning.
-(defvar *flame-on-necessarily-undefined-function* nil)
+(defvar *flame-on-necessarily-undefined-thing* nil)
(defvar *check-consistency* nil)
-(defvar *all-components*)
-;;; Set to NIL to disable loop analysis for register allocation.
+;;; Set to NIL to disable loop analysis for register allocation.
(defvar *loop-analyze* t)
;;; Bind this to a stream to capture various internal debugging output.
compiling.")
(declaim (type (or pathname null)
- sb!xc:*compile-file-pathname*
- sb!xc:*compile-file-truename*))
+ sb!xc:*compile-file-pathname*
+ sb!xc:*compile-file-truename*))
;;; the SOURCE-INFO structure for the current compilation. This is
;;; null globally to indicate that we aren't currently in any
(defvar *compile-object* nil)
(declaim (type object *compile-object*))
+(defvar *compile-toplevel-object* nil)
+
+(defvar *emit-cfasl* nil)
+
+(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
(defmacro sb!xc:with-compilation-unit (options &body body)
#!+sb-doc
- "WITH-COMPILATION-UNIT ({Key Value}*) Form*
- This form affects compilations that take place within its dynamic extent. It
- is intended to be wrapped around the compilation of all files in the same
- system. These keywords are defined:
- :OVERRIDE Boolean-Form
- One of the effects of this form is to delay undefined warnings
- until the end of the form, instead of giving them at the end of each
- compilation. If OVERRIDE is NIL (the default), then the outermost
- WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
- OVERRIDE true causes that form to grab any enclosed warnings, even if
- it is enclosed by another WITH-COMPILATION-UNIT."
+ "Affects compilations that take place within its dynamic extent. It is
+intended to be eg. wrapped around the compilation of all files in the same system.
+
+Following options are defined:
+
+ :OVERRIDE Boolean-Form
+ One of the effects of this form is to delay undefined warnings until the
+ end of the form, instead of giving them at the end of each compilation.
+ If OVERRIDE is NIL (the default), then the outermost
+ WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
+ OVERRIDE true causes that form to grab any enclosed warnings, even if it
+ is enclosed by another WITH-COMPILATION-UNIT.
+
+ :POLICY Optimize-Declaration-Form
+ Provides dynamic scoping for global compiler optimization qualities and
+ restrictions, limiting effects of subsequent OPTIMIZE proclamations and
+ calls to SB-EXT:RESTRICT-COMPILER-POLICY to the dynamic scope of BODY.
+
+ If OVERRIDE is false, specified POLICY is merged with current global
+ policy. If OVERRIDE is true, current global policy, including any
+ restrictions, is discarded in favor of the specified POLICY.
+
+ Supplying POLICY NIL is equivalent to the option not being supplied at
+ all, ie. dynamic scoping of policy does not take place.
+
+ This option is an SBCL-specific experimental extension: Interface
+ subject to change.
+
+ :SOURCE-NAMESTRING Namestring-Form
+ Attaches the value returned by the Namestring-Form to the internal
+ debug-source information as the namestring of the source file. Normally
+ the namestring of the input-file for COMPILE-FILE is used: this option
+ can be used to provide source-file information for functions compiled
+ using COMPILE, or to override the input-file of COMPILE-FILE.
+
+ If both an outer and an inner WITH-COMPILATION-UNIT provide a
+ SOURCE-NAMESTRING, the inner one takes precedence. Unaffected
+ by :OVERRIDE.
+
+ This is an SBCL-specific extension.
+
+ :SOURCE-PLIST Plist-Form
+ Attaches the value returned by the Plist-Form to internal debug-source
+ information of functions compiled in within the dynamic extent of BODY.
+
+ Primarily for use by development environments, in order to eg. associate
+ function definitions with editor-buffers. Can be accessed using
+ SB-INTROSPECT:DEFINITION-SOURCE-PLIST.
+
+ If an outer WITH-COMPILATION-UNIT form also provide a SOURCE-PLIST, it
+ is appended to the end of the provided SOURCE-PLIST. Unaffected
+ by :OVERRIDE.
+
+ This is an SBCL-specific extension.
+
+Examples:
+
+ ;; Prevent proclamations from the file leaking, and restrict
+ ;; SAFETY to 3 -- otherwise uses the current global policy.
+ (with-compilation-unit (:policy '(optimize))
+ (restrict-compiler-policy 'safety 3)
+ (load \"foo.lisp\"))
+
+ ;; Using default policy instead of the current global one,
+ ;; except for DEBUG 3.
+ (with-compilation-unit (:policy '(optimize debug)
+ :override t)
+ (load \"foo.lisp\"))
+
+ ;; Same as if :POLICY had not been specified at all: SAFETY 3
+ ;; proclamation leaks out from WITH-COMPILATION-UNIT.
+ (with-compilation-unit (:policy nil)
+ (declaim (optimize safety))
+ (load \"foo.lisp\"))
+"
`(%with-compilation-unit (lambda () ,@body) ,@options))
-(defun %with-compilation-unit (fn &key override)
+(defvar *source-plist* nil)
+(defvar *source-namestring* nil)
+
+(defun %with-compilation-unit (fn &key override policy source-plist source-namestring)
(declare (type function fn))
- (let ((succeeded-p nil))
- (if (and *in-compilation-unit* (not override))
- ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is
- ;; ordinarily (unless OVERRIDE) basically a no-op.
- (unwind-protect
- (multiple-value-prog1 (funcall fn) (setf succeeded-p t))
- (unless succeeded-p
- (incf *aborted-compilation-unit-count*)))
- (let ((*aborted-compilation-unit-count* 0)
- (*compiler-error-count* 0)
- (*compiler-warning-count* 0)
- (*compiler-style-warning-count* 0)
- (*compiler-note-count* 0)
- (*undefined-warnings* nil)
- (*in-compilation-unit* t))
- (sb!thread:with-recursive-lock (*big-compiler-lock*)
- (handler-bind ((parse-unknown-type
- (lambda (c)
- (note-undefined-reference
- (parse-unknown-type-specifier c)
- :type))))
- (unwind-protect
- (multiple-value-prog1 (funcall fn) (setf succeeded-p t))
- (unless succeeded-p
- (incf *aborted-compilation-unit-count*))
- (summarize-compilation-unit (not succeeded-p)))))))))
-
-;;; Is FUN-NAME something that no conforming program can rely on
-;;; defining as a function?
-(defun fun-name-reserved-by-ansi-p (fun-name)
- (eq (symbol-package (fun-name-block-name fun-name))
- *cl-package*))
+ (flet ((with-it ()
+ (let ((succeeded-p nil)
+ (*source-plist* (append source-plist *source-plist*))
+ (*source-namestring* (or source-namestring *source-namestring*)))
+ (if (and *in-compilation-unit* (not override))
+ ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is
+ ;; ordinarily (unless OVERRIDE) basically a no-op.
+ (unwind-protect
+ (multiple-value-prog1 (funcall fn) (setf succeeded-p t))
+ (unless succeeded-p
+ (incf *aborted-compilation-unit-count*)))
+ (let ((*aborted-compilation-unit-count* 0)
+ (*compiler-error-count* 0)
+ (*compiler-warning-count* 0)
+ (*compiler-style-warning-count* 0)
+ (*compiler-note-count* 0)
+ (*undefined-warnings* nil)
+ (*in-compilation-unit* t))
+ (handler-bind ((parse-unknown-type
+ (lambda (c)
+ (note-undefined-reference
+ (parse-unknown-type-specifier c)
+ :type))))
+ (unwind-protect
+ (multiple-value-prog1 (funcall fn) (setf succeeded-p t))
+ (unless succeeded-p
+ (incf *aborted-compilation-unit-count*))
+ (summarize-compilation-unit (not succeeded-p)))))))))
+ (if policy
+ (let ((*policy* (process-optimize-decl policy (unless override *policy*)))
+ (*policy-restrictions* (unless override *policy-restrictions*)))
+ (with-it))
+ (with-it))))
+
+;;; Is NAME something that no conforming program can rely on
+;;; defining?
+(defun name-reserved-by-ansi-p (name kind)
+ (ecase kind
+ (:function
+ (eq (symbol-package (fun-name-block-name name))
+ *cl-package*))
+ (:type
+ (let ((symbol (typecase name
+ (symbol name)
+ ((cons symbol) (car name))
+ (t (return-from name-reserved-by-ansi-p nil)))))
+ (eq (symbol-package symbol) *cl-package*)))))
;;; This is to be called at the end of a compilation unit. It signals
;;; any residual warnings about unknown stuff, then prints the total
;;; aborted by throwing out. ABORT-COUNT is the number of dynamically
;;; enclosed nested compilation units that were aborted.
(defun summarize-compilation-unit (abort-p)
- (unless abort-p
- (handler-bind ((style-warning #'compiler-style-warning-handler)
- (warning #'compiler-warning-handler))
-
- (let ((undefs (sort *undefined-warnings* #'string<
- :key (lambda (x)
- (let ((x (undefined-warning-name x)))
- (if (symbolp x)
- (symbol-name x)
- (prin1-to-string x)))))))
- (dolist (undef undefs)
- (let ((name (undefined-warning-name undef))
- (kind (undefined-warning-kind undef))
- (warnings (undefined-warning-warnings undef))
- (undefined-warning-count (undefined-warning-count undef)))
- (dolist (*compiler-error-context* warnings)
- (if #-sb-xc-host (and (eq kind :function)
- (fun-name-reserved-by-ansi-p name)
- *flame-on-necessarily-undefined-function*)
- #+sb-xc-host nil
- (case name
- ((declare)
- (compiler-warn
- "~@<There is no function named ~S. References to ~S in ~
- some contexts (like starts of blocks) have special ~
- meaning, but here it would have to be a function, ~
- and that shouldn't be right.~:@>"
- name name))
- (t
- (compiler-warn
- "~@<The ~(~A~) ~S is undefined, and its name is ~
- reserved by ANSI CL so that even if it were ~
- defined later, the code doing so would not be ~
- portable.~:@>"
- kind name)))
- (if (eq kind :variable)
- (compiler-warn "undefined ~(~A~): ~S" kind name)
- (compiler-style-warn "undefined ~(~A~): ~S" kind name))))
- (let ((warn-count (length warnings)))
- (when (and warnings (> undefined-warning-count warn-count))
- (let ((more (- undefined-warning-count warn-count)))
- (if (eq kind :variable)
- (compiler-warn
- "~W more use~:P of undefined ~(~A~) ~S"
- more kind name)
- (compiler-style-warn
- "~W more use~:P of undefined ~(~A~) ~S"
- more kind name)))))))
-
- (dolist (kind '(:variable :function :type))
- (let ((summary (mapcar #'undefined-warning-name
- (remove kind undefs :test #'neq
- :key #'undefined-warning-kind))))
- (when summary
- (if (eq kind :variable)
- (compiler-warn
- "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
- ~% ~{~<~% ~1:;~S~>~^ ~}"
- (cdr summary) kind summary)
- (compiler-style-warn
- "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
- ~% ~{~<~% ~1:;~S~>~^ ~}"
- (cdr summary) kind summary))))))))
-
- (unless (and (not abort-p)
- (zerop *aborted-compilation-unit-count*)
- (zerop *compiler-error-count*)
- (zerop *compiler-warning-count*)
- (zerop *compiler-style-warning-count*)
- (zerop *compiler-note-count*))
- (fresh-line *standard-output*)
- (pprint-logical-block (*standard-output* nil :per-line-prefix "; ")
- (compiler-mumble "compilation unit ~:[finished~;aborted~]~
- ~[~:;~:*~& caught ~W fatal ERROR condition~:P~]~
- ~[~:;~:*~& caught ~W ERROR condition~:P~]~
- ~[~:;~:*~& caught ~W WARNING condition~:P~]~
- ~[~:;~:*~& caught ~W STYLE-WARNING condition~:P~]~
- ~[~:;~:*~& printed ~W note~:P~]"
- abort-p
- *aborted-compilation-unit-count*
- *compiler-error-count*
- *compiler-warning-count*
- *compiler-style-warning-count*
- *compiler-note-count*)))
- (fresh-line *standard-output*))
+ (let (summary)
+ (unless abort-p
+ (handler-bind ((style-warning #'compiler-style-warning-handler)
+ (warning #'compiler-warning-handler))
+
+ (let ((undefs (sort *undefined-warnings* #'string<
+ :key (lambda (x)
+ (let ((x (undefined-warning-name x)))
+ (if (symbolp x)
+ (symbol-name x)
+ (prin1-to-string x)))))))
+ (dolist (kind '(:variable :function :type))
+ (let ((names (mapcar #'undefined-warning-name
+ (remove kind undefs :test #'neq
+ :key #'undefined-warning-kind))))
+ (when names (push (cons kind names) summary))))
+ (dolist (undef undefs)
+ (let ((name (undefined-warning-name undef))
+ (kind (undefined-warning-kind undef))
+ (warnings (undefined-warning-warnings undef))
+ (undefined-warning-count (undefined-warning-count undef)))
+ (dolist (*compiler-error-context* warnings)
+ (if #-sb-xc-host (and (member kind '(:function :type))
+ (name-reserved-by-ansi-p name kind)
+ *flame-on-necessarily-undefined-thing*)
+ #+sb-xc-host nil
+ (ecase kind
+ (:function
+ (case name
+ ((declare)
+ (compiler-warn
+ "~@<There is no function named ~S. References to ~S ~
+ in some contexts (like starts of blocks) have ~
+ special meaning, but here it would have to be a ~
+ function, and that shouldn't be right.~:@>" name
+ name))
+ (t
+ (compiler-warn
+ "~@<The function ~S is undefined, and its name is ~
+ reserved by ANSI CL so that even if it were ~
+ defined later, the code doing so would not be ~
+ portable.~:@>" name))))
+ (:type
+ (if (and (consp name) (eq 'quote (car name)))
+ (compiler-warn
+ "~@<Undefined type ~S. The name starts with ~S: ~
+ probably use of a quoted type name in a context ~
+ where the name is not evaluated.~:@>"
+ name 'quote)
+ (compiler-warn
+ "~@<Undefined type ~S. Note that name ~S is ~
+ reserved by ANSI CL, so code defining a type with ~
+ that name would not be portable.~:@>" name
+ name))))
+ (if (eq kind :variable)
+ (compiler-warn "undefined ~(~A~): ~S" kind name)
+ (compiler-style-warn "undefined ~(~A~): ~S" kind name))))
+ (let ((warn-count (length warnings)))
+ (when (and warnings (> undefined-warning-count warn-count))
+ (let ((more (- undefined-warning-count warn-count)))
+ (if (eq kind :variable)
+ (compiler-warn
+ "~W more use~:P of undefined ~(~A~) ~S"
+ more kind name)
+ (compiler-style-warn
+ "~W more use~:P of undefined ~(~A~) ~S"
+ more kind name))))))))))
+
+ (unless (and (not abort-p)
+ (zerop *aborted-compilation-unit-count*)
+ (zerop *compiler-error-count*)
+ (zerop *compiler-warning-count*)
+ (zerop *compiler-style-warning-count*)
+ (zerop *compiler-note-count*))
+ (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
+ (format *error-output* "~&compilation unit ~:[finished~;aborted~]"
+ abort-p)
+ (dolist (cell summary)
+ (destructuring-bind (kind &rest names) cell
+ (format *error-output*
+ "~& Undefined ~(~A~)~p:~
+ ~% ~{~<~% ~1:;~S~>~^ ~}"
+ kind (length names) names)))
+ (format *error-output* "~[~:;~:*~& caught ~W fatal ERROR condition~:P~]~
+ ~[~:;~:*~& caught ~W ERROR condition~:P~]~
+ ~[~:;~:*~& caught ~W WARNING condition~:P~]~
+ ~[~:;~:*~& caught ~W STYLE-WARNING condition~:P~]~
+ ~[~:;~:*~& printed ~W note~:P~]"
+ *aborted-compilation-unit-count*
+ *compiler-error-count*
+ *compiler-warning-count*
+ *compiler-style-warning-count*
+ *compiler-note-count*))
+ (terpri *error-output*)
+ (force-output *error-output*))))
;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P
;;; FAILURE-P), where BODY-VALUE is the first value of the body, and
;;; WARNINGS-P and FAILURE-P are as in CL:COMPILE or CL:COMPILE-FILE.
;;; This also wraps up WITH-IR1-NAMESPACE functionality.
(defmacro with-compilation-values (&body body)
- `(with-ir1-namespace
- (let ((*warnings-p* nil)
- (*failure-p* nil))
- (values (progn ,@body)
- *warnings-p*
- *failure-p*))))
+ ;; These bindings could just as well be in WITH-IR1-NAMESPACE, but
+ ;; since they're primarily debugging tools, it's nicer to have
+ ;; a wider unique scope by ID.
+ `(let ((*continuation-number* 0)
+ (*continuation-numbers* (make-hash-table :test 'eq))
+ (*number-continuations* (make-hash-table :test 'eql))
+ (*tn-id* 0)
+ (*tn-ids* (make-hash-table :test 'eq))
+ (*id-tns* (make-hash-table :test 'eql))
+ (*label-id* 0)
+ (*label-ids* (make-hash-table :test 'eq))
+ (*id-labels* (make-hash-table :test 'eql)))
+ (unwind-protect
+ (let ((*warnings-p* nil)
+ (*failure-p* nil))
+ (handler-bind ((compiler-error #'compiler-error-handler)
+ (style-warning #'compiler-style-warning-handler)
+ (warning #'compiler-warning-handler))
+ (values (progn ,@body)
+ *warnings-p*
+ *failure-p*)))
+ (clrhash *tn-ids*)
+ (clrhash *id-tns*)
+ (clrhash *continuation-numbers*)
+ (clrhash *number-continuations*)
+ (clrhash *label-ids*)
+ (clrhash *id-labels*))))
\f
;;;; component compilation
(defparameter *max-optimize-iterations* 3 ; ARB
#!+sb-doc
"The upper limit on the number of times that we will consecutively do IR1
- optimization that doesn't introduce any new code. A finite limit is
- necessary, since type inference may take arbitrarily long to converge.")
+optimization that doesn't introduce any new code. A finite limit is
+necessary, since type inference may take arbitrarily long to converge.")
(defevent ir1-optimize-until-done "IR1-OPTIMIZE-UNTIL-DONE called")
(defevent ir1-optimize-maxed-out "hit *MAX-OPTIMIZE-ITERATIONS* limit")
(maybe-mumble "opt")
(event ir1-optimize-until-done)
(let ((count 0)
- (cleared-reanalyze nil)
+ (cleared-reanalyze nil)
(fastp nil))
(loop
(when (component-reanalyze component)
- (setq count 0)
- (setq cleared-reanalyze t)
- (setf (component-reanalyze component) nil))
+ (setq count 0)
+ (setq cleared-reanalyze t)
+ (setf (component-reanalyze component) nil))
(setf (component-reoptimize component) nil)
(ir1-optimize component fastp)
(cond ((component-reoptimize component)
(eq (component-reoptimize component) :maybe))
(maybe-mumble "*")
(cond ((retry-delayed-ir1-transforms :optimize)
- (maybe-mumble "+")
- (setq count 0))
+ (maybe-mumble "+")
+ (setq count 0))
(t
- (event ir1-optimize-maxed-out)
- (setf (component-reoptimize component) nil)
- (do-blocks (block component)
- (setf (block-reoptimize block) nil))
- (return)))))
+ (event ir1-optimize-maxed-out)
+ (setf (component-reoptimize component) nil)
+ (do-blocks (block component)
+ (setf (block-reoptimize block) nil))
+ (return)))))
((retry-delayed-ir1-transforms :optimize)
- (setf count 0)
- (maybe-mumble "+"))
- (t
+ (setf count 0)
+ (maybe-mumble "+"))
+ (t
(maybe-mumble " ")
- (return)))
+ (return)))
(setq fastp (>= count *max-optimize-iterations*))
(maybe-mumble (if fastp "-" ".")))
(when cleared-reanalyze
(loop
(find-dfo component)
(unless (component-reanalyze component)
- (maybe-mumble " ")
- (return))
+ (maybe-mumble " ")
+ (return))
(maybe-mumble ".")))
(values))
(defun ir1-phases (component)
(declare (type component component))
(aver-live-component component)
- (let ((*constraint-number* 0)
- (loop-count 1)
+ (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)
- (component-reanalyze-functionals component))
- (maybe-mumble "locall ")
- (locall-analyze-component component))
+ (component-reanalyze-functionals component))
+ (maybe-mumble "locall ")
+ (locall-analyze-component component))
(dfo-as-needed component)
(when *constraint-propagate*
- (maybe-mumble "constraint ")
- (constraint-propagate component))
+ (maybe-mumble "constraint ")
+ (constraint-propagate component))
(when (retry-delayed-ir1-transforms :constraint)
(maybe-mumble "Rtran "))
(flet ((want-reoptimization-p ()
- (or (component-reoptimize component)
- (component-reanalyze component)
- (component-new-functionals component)
- (component-reanalyze-functionals component))))
- (unless (and (want-reoptimization-p)
- ;; We delay the generation of type checks until
- ;; the type constraints have had time to
- ;; propagate, else the compiler can confuse itself.
- (< loop-count (- *reoptimize-after-type-check-max* 4)))
- (maybe-mumble "type ")
- (generate-type-checks component)
- (unless (want-reoptimization-p)
- (return))))
+ (or (component-reoptimize component)
+ (component-reanalyze component)
+ (component-new-functionals component)
+ (component-reanalyze-functionals component))))
+ (unless (and (want-reoptimization-p)
+ ;; We delay the generation of type checks until
+ ;; the type constraints have had time to
+ ;; propagate, else the compiler can confuse itself.
+ (< loop-count (- *reoptimize-after-type-check-max* 4)))
+ (maybe-mumble "type ")
+ (generate-type-checks component)
+ (unless (want-reoptimization-p)
+ (return))))
(when (>= loop-count *reoptimize-after-type-check-max*)
- (maybe-mumble "[reoptimize limit]")
- (event reoptimize-maxed-out)
- (return))
+ (maybe-mumble "[reoptimize limit]")
+ (event reoptimize-maxed-out)
+ (return))
(incf loop-count)))
+ (when *check-consistency*
+ (do-blocks-backwards (block component)
+ (awhen (flush-dead-code block)
+ (let ((*compiler-error-context* it))
+ (compiler-warn "dead code detected at the end of ~S"
+ 'ir1-phases)))))
+
(ir1-finalize component)
(values))
(defun %compile-component (component)
(let ((*code-segment* nil)
- (*elsewhere* nil))
+ (*elsewhere* nil)
+ #!+inline-constants
+ (*constant-segment* nil)
+ #!+inline-constants
+ (*constant-table* nil)
+ #!+inline-constants
+ (*constant-vector* nil))
(maybe-mumble "GTN ")
(gtn-analyze component)
(maybe-mumble "LTN ")
(dfo-as-needed component))
(unwind-protect
- (progn
- (maybe-mumble "IR2tran ")
- (init-assembler)
- (entry-analyze component)
- (ir2-convert component)
+ (progn
+ (maybe-mumble "IR2tran ")
+ (init-assembler)
+ (entry-analyze component)
+ (ir2-convert component)
- (when (policy *lexenv* (>= speed compilation-speed))
- (maybe-mumble "copy ")
- (copy-propagate component))
+ (when (policy *lexenv* (>= speed compilation-speed))
+ (maybe-mumble "copy ")
+ (copy-propagate component))
- (select-representations component)
+ (ir2-optimize component)
- (when *check-consistency*
- (maybe-mumble "check2 ")
- (check-ir2-consistency component))
+ (select-representations component)
- (delete-unreferenced-tns component)
+ (when *check-consistency*
+ (maybe-mumble "check2 ")
+ (check-ir2-consistency component))
- (maybe-mumble "life ")
- (lifetime-analyze component)
+ (delete-unreferenced-tns component)
- (when *compile-progress*
- (compiler-mumble "") ; Sync before doing more output.
- (pre-pack-tn-stats component *standard-output*))
+ (maybe-mumble "life ")
+ (lifetime-analyze component)
- (when *check-consistency*
- (maybe-mumble "check-life ")
- (check-life-consistency component))
+ (when *compile-progress*
+ (compiler-mumble "") ; Sync before doing more output.
+ (pre-pack-tn-stats component *standard-output*))
- (maybe-mumble "pack ")
- (pack component)
+ (when *check-consistency*
+ (maybe-mumble "check-life ")
+ (check-life-consistency component))
- (when *check-consistency*
- (maybe-mumble "check-pack ")
- (check-pack-consistency component))
+ (maybe-mumble "pack ")
+ (sb!regalloc:pack component)
- (when *compiler-trace-output*
- (describe-component component *compiler-trace-output*)
- (describe-ir2-component component *compiler-trace-output*))
+ (when *check-consistency*
+ (maybe-mumble "check-pack ")
+ (check-pack-consistency component))
- (maybe-mumble "code ")
- (multiple-value-bind (code-length trace-table fixup-notes)
- (generate-code component)
+ (when *compiler-trace-output*
+ (describe-component component *compiler-trace-output*)
+ (describe-ir2-component component *compiler-trace-output*))
+
+ (maybe-mumble "code ")
+ (multiple-value-bind (code-length trace-table fixup-notes)
+ (generate-code component)
#-sb-xc-host
- (when *compiler-trace-output*
- (format *compiler-trace-output*
- "~|~%disassembly of code for ~S~2%" component)
- (sb!disassem:disassemble-assem-segment *code-segment*
- *compiler-trace-output*))
-
- (etypecase *compile-object*
- (fasl-output
- (maybe-mumble "fasl")
- (fasl-dump-component component
- *code-segment*
- code-length
- trace-table
- fixup-notes
- *compile-object*))
- (core-object
- (maybe-mumble "core")
- (make-core-component component
- *code-segment*
- code-length
- trace-table
- fixup-notes
- *compile-object*))
- (null))))))
+ (when *compiler-trace-output*
+ (format *compiler-trace-output*
+ "~|~%disassembly of code for ~S~2%" component)
+ (sb!disassem:disassemble-assem-segment *code-segment*
+ *compiler-trace-output*))
+
+ (etypecase *compile-object*
+ (fasl-output
+ (maybe-mumble "fasl")
+ (fasl-dump-component component
+ *code-segment*
+ code-length
+ trace-table
+ fixup-notes
+ *compile-object*))
+ (core-object
+ (maybe-mumble "core")
+ (make-core-component component
+ *code-segment*
+ code-length
+ trace-table
+ fixup-notes
+ *compile-object*))
+ (null))))))
;; We're done, so don't bother keeping anything around.
(setf (component-info component) :dead)
(:toplevel (return))
(:external
(unless (every (lambda (ref)
- (eq (node-component ref) component))
- (leaf-refs fun))
- (return))))))
+ (eq (node-component ref) component))
+ (leaf-refs fun))
+ (return))))))
(defun compile-component (component)
(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*
#|
(when (and *loop-analyze* *compiler-trace-output*)
(labels ((print-blocks (block)
- (format *compiler-trace-output* " ~A~%" block)
- (when (block-loop-next block)
- (print-blocks (block-loop-next block))))
- (print-loop (loop)
- (format *compiler-trace-output* "loop=~A~%" loop)
- (print-blocks (loop-blocks loop))
- (dolist (l (loop-inferiors loop))
- (print-loop l))))
- (print-loop (component-outer-loop component))))
+ (format *compiler-trace-output* " ~A~%" block)
+ (when (block-loop-next block)
+ (print-blocks (block-loop-next block))))
+ (print-loop (loop)
+ (format *compiler-trace-output* "loop=~A~%" loop)
+ (print-blocks (loop-blocks loop))
+ (dolist (l (loop-inferiors loop))
+ (print-loop l))))
+ (print-loop (component-outer-loop component))))
|#
-
+
;; FIXME: What is MAYBE-MUMBLE for? Do we need it any more?
(maybe-mumble "env ")
(physenv-analyze component)
(delete-if-no-entries component)
(unless (eq (block-next (component-head component))
- (component-tail component))
+ (component-tail component))
(%compile-component component)))
(clear-constant-info)
-
+
(values))
\f
;;;; clearing global data structures
;;; component boundaries.
(defun clear-constant-info ()
(maphash (lambda (k v)
- (declare (ignore k))
- (setf (leaf-info v) nil))
- *constants*)
+ (declare (ignore k))
+ (setf (leaf-info v) nil)
+ (setf (constant-boxed-tn v) nil))
+ *constants*)
(maphash (lambda (k v)
- (declare (ignore k))
- (when (constant-p v)
- (setf (leaf-info v) nil)))
- *free-vars*)
+ (declare (ignore k))
+ (when (constant-p v)
+ (setf (leaf-info v) nil)
+ (setf (constant-boxed-tn v) nil)))
+ *free-vars*)
(values))
;;; Blow away the REFS for all global variables, and let COMPONENT
(defun clear-ir1-info (component)
(declare (type component component))
(labels ((blast (x)
- (maphash (lambda (k v)
- (declare (ignore k))
- (when (leaf-p v)
- (setf (leaf-refs v)
- (delete-if #'here-p (leaf-refs v)))
- (when (basic-var-p v)
- (setf (basic-var-sets v)
- (delete-if #'here-p (basic-var-sets v))))))
- x))
- (here-p (x)
- (eq (node-component x) component)))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (when (leaf-p v)
+ (setf (leaf-refs v)
+ (delete-if #'here-p (leaf-refs v)))
+ (when (basic-var-p v)
+ (setf (basic-var-sets v)
+ (delete-if #'here-p (basic-var-sets v))))))
+ x))
+ (here-p (x)
+ (eq (node-component x) component)))
(blast *free-vars*)
(blast *free-funs*)
(blast *constants*))
(values))
-
-;;; Clear global variables used by the compiler.
-;;;
-;;; FIXME: It seems kinda nasty and unmaintainable to have to do this,
-;;; and it adds overhead even when people aren't using the compiler.
-;;; Perhaps we could make these global vars unbound except when
-;;; actually in use, so that this function could go away.
-(defun clear-stuff (&optional (debug-too t))
-
- ;; Clear global tables.
- (when (boundp '*free-funs*)
- (clrhash *free-funs*)
- (clrhash *free-vars*)
- (clrhash *constants*))
-
- ;; Clear debug counters and tables.
- (clrhash *seen-blocks*)
- (clrhash *seen-funs*)
- (clrhash *list-conflicts-table*)
-
- (when debug-too
- (clrhash *continuation-numbers*)
- (clrhash *number-continuations*)
- (setq *continuation-number* 0)
- (clrhash *tn-ids*)
- (clrhash *id-tns*)
- (setq *tn-id* 0)
- (clrhash *label-ids*)
- (clrhash *id-labels*)
- (setq *label-id* 0))
-
- ;; (Note: The CMU CL code used to set CL::*GENSYM-COUNTER* to zero here.
- ;; Superficially, this seemed harmful -- the user could reasonably be
- ;; surprised if *GENSYM-COUNTER* turned back to zero when something was
- ;; compiled. A closer inspection showed that this actually turned out to be
- ;; harmless in practice, because CLEAR-STUFF was only called from within
- ;; forms which bound CL::*GENSYM-COUNTER* to zero. However, this means that
- ;; even though zeroing CL::*GENSYM-COUNTER* here turned out to be harmless in
- ;; practice, it was also useless in practice. So we don't do it any more.)
-
- (values))
\f
;;;; trace output
(format t "entries:~%")
(dolist (entry (ir2-component-entries (component-info component)))
(format t "~4TL~D: ~S~:[~; [closure]~]~%"
- (label-id (entry-info-offset entry))
- (entry-info-name entry)
- (entry-info-closure-tn entry)))
+ (label-id (entry-info-offset entry))
+ (entry-info-name entry)
+ (entry-info-closure-tn entry)))
(terpri)
(pre-pack-tn-stats component *standard-output*)
(terpri)
;;; 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
;;; The SOURCE-INFO structure provides a handle on all the source
;;; information for an entire compilation.
(def!struct (source-info
- #-no-ansi-print-object
- (:print-object (lambda (s stream)
- (print-unreadable-object (s stream :type t))))
- (:copier nil))
+ #-no-ansi-print-object
+ (:print-object (lambda (s stream)
+ (print-unreadable-object (s stream :type t))))
+ (:copier nil))
;; the UT that compilation started at
(start-time (get-universal-time) :type unsigned-byte)
+ ;; the IRT that compilation started at
+ (start-real-time (get-internal-real-time) :type unsigned-byte)
;; the FILE-INFO structure for this compilation
(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 file
- :external-format external-format
- :write-date (file-write-date file))))
-
- (make-source-info :file-info file-info)))
-
-;;; 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)))
+ (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 &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
;;; error condition (possibly recording some extra location
;;; information).
(defun read-for-compile-file (stream position)
- (handler-case (read stream nil stream)
+ (handler-case
+ (read-preserving-whitespace stream nil stream)
(reader-error (condition)
- (error 'input-error-in-compile-file
- :condition condition
- ;; We don't need to supply :POSITION here because
- ;; READER-ERRORs already know their position in the file.
- ))
+ (compiler-error 'input-error-in-compile-file
+ ;; We don't need to supply :POSITION here because
+ ;; READER-ERRORs already know their position in the file.
+ :condition condition
+ :stream stream))
;; ANSI, in its wisdom, says that READ should return END-OF-FILE
;; (and that this is not a READER-ERROR) when it encounters end of
;; file in the middle of something it's trying to read.
(end-of-file (condition)
- (error 'input-error-in-compile-file
- :condition condition
- ;; We need to supply :POSITION here because the END-OF-FILE
- ;; condition doesn't carry the position that the user
- ;; probably cares about, where the failed READ began.
- :position position))))
+ (compiler-error 'input-error-in-compile-file
+ :condition condition
+ ;; We need to supply :POSITION here because the END-OF-FILE
+ ;; condition doesn't carry the position that the user
+ ;; probably cares about, where the failed READ began.
+ :position position
+ :stream stream))
+ (error (condition)
+ (compiler-error 'input-error-in-compile-file
+ :condition condition
+ :position position
+ :stream stream))))
;;; If STREAM is present, return it, otherwise open a stream to the
;;; current file. There must be a current file.
(declare (type source-info info))
(or (source-info-stream info)
(let* ((file-info (source-info-file-info info))
- (name (file-info-name file-info))
+ (name (file-info-name file-info))
(external-format (file-info-external-format file-info)))
- (setf sb!xc:*compile-file-truename* name
- sb!xc:*compile-file-pathname* (file-info-untruename file-info)
- (source-info-stream info)
+ (setf sb!xc:*compile-file-truename* name
+ sb!xc:*compile-file-pathname* (file-info-untruename file-info)
+ (source-info-stream info)
(open name :direction :input
:external-format external-format)))))
(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)
+ (with-source-paths
+ (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.
(declare (type index index) (type source-info info))
(let ((file-info (source-info-file-info info)))
(values (aref (file-info-forms file-info) index)
- (aref (file-info-positions file-info) index))))
+ (aref (file-info-positions file-info) index))))
\f
;;;; processing of top level forms
;;; *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))
+ (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))
+ (with-ir1-namespace
+ (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
;;; forms in the source path.
(defun preprocessor-macroexpand-1 (form)
- (handler-case (sb!xc:macroexpand-1 form *lexenv*)
+ (handler-case (%macroexpand-1 form *lexenv*)
(error (condition)
(compiler-error "(during macroexpansion of ~A)~%~A"
- (let ((*print-level* 2)
- (*print-length* 2))
- (format nil "~S" form))
- condition))))
+ (let ((*print-level* 2)
+ (*print-length* 2))
+ (format nil "~S" form))
+ condition))))
;;; Process a PROGN-like portion of a top level form. FORMS is a list of
;;; the forms, and PATH is the source path of the FORM they came out of.
(declare (list path))
(multiple-value-bind (forms decls)
(parse-body body :doc-string-allowed nil :toplevel t)
- (let* ((*lexenv* (process-decls decls vars funs))
- ;; FIXME: VALUES declaration
- ;;
- ;; Binding *POLICY* is pretty much of a hack, since it
- ;; causes LOCALLY to "capture" enclosed proclamations. It
- ;; is necessary because CONVERT-AND-MAYBE-COMPILE uses the
- ;; value of *POLICY* as the policy. The need for this hack
- ;; is due to the quirk that there is no way to represent in
- ;; a POLICY that an optimize quality came from the default.
- ;;
- ;; FIXME: Ideally, something should be done so that DECLAIM
- ;; inside LOCALLY works OK. Failing that, at least we could
- ;; issue a warning instead of silently screwing up.
- (*policy* (lexenv-policy *lexenv*))
- ;; This is probably also a hack
- (*handled-conditions* (lexenv-handled-conditions *lexenv*))
- ;; ditto
- (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*)))
- (process-toplevel-progn forms path compile-time-too))))
+ (with-ir1-namespace
+ (let* ((*lexenv* (process-decls decls vars funs))
+ ;; FIXME: VALUES declaration
+ ;;
+ ;; Binding *POLICY* is pretty much of a hack, since it
+ ;; causes LOCALLY to "capture" enclosed proclamations. It
+ ;; is necessary because CONVERT-AND-MAYBE-COMPILE uses the
+ ;; value of *POLICY* as the policy. The need for this hack
+ ;; is due to the quirk that there is no way to represent in
+ ;; a POLICY that an optimize quality came from the default.
+ ;;
+ ;; FIXME: Ideally, something should be done so that DECLAIM
+ ;; inside LOCALLY works OK. Failing that, at least we could
+ ;; issue a warning instead of silently screwing up.
+ (*policy* (lexenv-policy *lexenv*))
+ ;; This is probably also a hack
+ (*handled-conditions* (lexenv-handled-conditions *lexenv*))
+ ;; ditto
+ (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*)))
+ (process-toplevel-progn forms path compile-time-too)))))
;;; Parse an EVAL-WHEN situations list, returning three flags,
;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
;;; the types of situations present in the list.
(defun parse-eval-when-situations (situations)
(when (or (not (listp situations))
- (set-difference situations
- '(:compile-toplevel
- compile
- :load-toplevel
- load
- :execute
- eval)))
+ (set-difference situations
+ '(:compile-toplevel
+ compile
+ :load-toplevel
+ load
+ :execute
+ eval)))
(compiler-error "bad EVAL-WHEN situation list: ~S" situations))
(let ((deprecated-names (intersection situations '(compile load eval))))
(when deprecated-names
(style-warn "using deprecated EVAL-WHEN situation names~{ ~S~}"
- deprecated-names)))
+ deprecated-names)))
(values (intersection '(:compile-toplevel compile)
- situations)
- (intersection '(:load-toplevel load) situations)
- (intersection '(:execute eval) situations)))
+ situations)
+ (intersection '(:load-toplevel load) situations)
+ (intersection '(:execute eval) situations)))
;;; utilities for extracting COMPONENTs of FUNCTIONALs
(etypecase f
(clambda (list (lambda-component f)))
(optional-dispatch (let ((result nil))
- (flet ((maybe-frob (maybe-clambda)
+ (flet ((maybe-frob (maybe-clambda)
(when (and maybe-clambda
(promise-ready-p maybe-clambda))
(pushnew (lambda-component
(force maybe-clambda))
- result))))
- (map nil #'maybe-frob (optional-dispatch-entry-points f))
- (maybe-frob (optional-dispatch-more-entry f))
- (maybe-frob (optional-dispatch-main-entry f)))
+ result))))
+ (map nil #'maybe-frob (optional-dispatch-entry-points f))
+ (maybe-frob (optional-dispatch-more-entry f))
+ (maybe-frob (optional-dispatch-main-entry f)))
result))))
-(defun make-functional-from-toplevel-lambda (definition
- &key
- name
- (path
- ;; I'd thought NIL should
- ;; work, but it doesn't.
- ;; -- WHN 2001-09-20
- (missing-arg)))
+(defun make-functional-from-toplevel-lambda (lambda-expression
+ &key
+ name
+ (path
+ ;; I'd thought NIL should
+ ;; work, but it doesn't.
+ ;; -- WHN 2001-09-20
+ (missing-arg)))
(let* ((*current-path* path)
(component (make-empty-component))
- (*current-component* component))
- (setf (component-name component)
- (debug-namify "~S initial component" name))
- (setf (component-kind component) :initial)
- (let* ((locall-fun (let ((*allow-instrumenting* t))
- (ir1-convert-lambdalike
- definition
- :debug-name (debug-namify "top level local call "
- name))))
- (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
- :source-name (or name '.anonymous.)
- :debug-name (unless name
- "top level form"))))
+ (*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* ((fun (let ((*allow-instrumenting* t))
+ (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 fun))))
+ (xep (ir1-convert-lambda (make-xep-lambda-expression fun)
+ :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 fun) t)
- fun)))
+ (assert-global-function-definition-type name fun))
+ (setf (functional-kind xep) :external
+ (functional-entry-fun xep) fun
+ (functional-entry-fun fun) xep
+ (component-reanalyze component) t
+ (functional-has-external-references-p xep) t)
+ (reoptimize-component component :maybe)
+ (locall-analyze-xep-entry-point fun)
+ ;; Any leftover REFs to FUN outside local calls get replaced with the
+ ;; XEP.
+ (substitute-leaf-if (lambda (ref)
+ (let* ((lvar (ref-lvar ref))
+ (dest (when lvar (lvar-dest lvar)))
+ (kind (when (basic-combination-p dest)
+ (basic-combination-kind dest))))
+ (neq :local kind)))
+ xep
+ fun)
+ xep)))
;;; Compile LAMBDA-EXPRESSION into *COMPILE-OBJECT*, returning a
;;; description of the result.
;;; If NAME is provided, then we try to use it as the name of the
;;; function for debugging/diagnostic information.
(defun %compile (lambda-expression
- *compile-object*
- &key
- name
- (path
- ;; This magical idiom seems to be the appropriate
- ;; path for compiling standalone LAMBDAs, judging
- ;; from the CMU CL code and experiment, so it's a
- ;; nice default for things where we don't have a
- ;; real source path (as in e.g. inside CL:COMPILE).
- '(original-source-start 0 0)))
+ *compile-object*
+ &key
+ name
+ (path
+ ;; This magical idiom seems to be the appropriate
+ ;; path for compiling standalone LAMBDAs, judging
+ ;; from the CMU CL code and experiment, so it's a
+ ;; nice default for things where we don't have a
+ ;; real source path (as in e.g. inside CL:COMPILE).
+ '(original-source-start 0 0)))
(when name
(legal-fun-name-or-type-error name))
- (let* (
- (*lexenv* (make-lexenv :policy *policy*
- :handled-conditions *handled-conditions*
- :disabled-package-locks *disabled-package-locks*))
- (fun (make-functional-from-toplevel-lambda lambda-expression
- :name name
- :path path)))
-
- ;; FIXME: The compile-it code from here on is sort of a
- ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be
- ;; better to find a way to share the code there; or
- ;; alternatively, to use this code to replace the code there.
- ;; (The second alternative might be pretty easy if we used
- ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the
- ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
-
- (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)))
+ (with-ir1-namespace
+ (let* ((*lexenv* (make-lexenv
+ :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)))
+
+ ;; FIXME: The compile-it code from here on is sort of a
+ ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be
+ ;; better to find a way to share the code there; or
+ ;; alternatively, to use this code to replace the code there.
+ ;; (The second alternative might be pretty easy if we used
+ ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the
+ ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
+
+ (locall-analyze-clambdas-until-done (list fun))
+
+ (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
- *compile-object*))
- (core-object (core-object-entry-table
- *compile-object*)))))
- (multiple-value-bind (result found-p)
- (gethash (leaf-info fun) entry-table)
- (aver found-p)
- (prog1
- result
- ;; KLUDGE: This code duplicates some other code in this
- ;; file. In the great reorganzation, the flow of program
- ;; logic changed from the original CMUCL model, and that
- ;; path (as of sbcl-0.7.5 in SUB-COMPILE-FILE) was no
- ;; longer followed for CORE-OBJECTS, leading to BUG
- ;; 156. This place is transparently not the right one for
- ;; this code, but I don't have a clear enough overview of
- ;; the compiler to know how to rearrange it all so that
- ;; this operation fits in nicely, and it was blocking
- ;; reimplementation of (DECLAIM (INLINE FOO)) (MACROLET
- ;; ((..)) (DEFUN FOO ...))
- ;;
- ;; FIXME: This KLUDGE doesn't solve all the problem in an
- ;; ideal way, as (1) definitions typed in at the REPL
- ;; without an INLINE declaration will give a NULL
- ;; FUNCTION-LAMBDA-EXPRESSION (allowable, but not ideal)
- ;; and (2) INLINE declarations will yield a
- ;; FUNCTION-LAMBDA-EXPRESSION headed by
- ;; SB-C:LAMBDA-WITH-LEXENV, even for null LEXENV. -- CSR,
- ;; 2002-07-02
- ;;
- ;; (2) is probably fairly easy to fix -- it is, after all,
- ;; a matter of list manipulation (or possibly of teaching
- ;; CL:FUNCTION about SB-C:LAMBDA-WITH-LEXENV). (1) is
- ;; significantly harder, as the association between
- ;; function object and source is a tricky one.
- ;;
- ;; FUNCTION-LAMBDA-EXPRESSION "works" (i.e. returns a
- ;; non-NULL list) when the function in question has been
- ;; compiled by (COMPILE <x> '(LAMBDA ...)); it does not
- ;; work when it has been compiled as part of the top-level
- ;; EVAL strategy of compiling everything inside (LAMBDA ()
- ;; ...). -- CSR, 2002-11-02
- (when (core-object-p *compile-object*)
- (fix-core-source-info *source-info* *compile-object* result))
-
- (mapc #'clear-ir1-info components-from-dfo)
- (clear-stuff)))))))
+ (replace-toplevel-xeps component-from-dfo))
+
+ (let ((entry-table (etypecase *compile-object*
+ (fasl-output (fasl-output-entry-table
+ *compile-object*))
+ (core-object (core-object-entry-table
+ *compile-object*)))))
+ (multiple-value-bind (result found-p)
+ (gethash (leaf-info fun) entry-table)
+ (aver found-p)
+ (prog1
+ result
+ ;; KLUDGE: This code duplicates some other code in this
+ ;; file. In the great reorganzation, the flow of program
+ ;; logic changed from the original CMUCL model, and that
+ ;; path (as of sbcl-0.7.5 in SUB-COMPILE-FILE) was no
+ ;; longer followed for CORE-OBJECTS, leading to BUG
+ ;; 156. This place is transparently not the right one for
+ ;; this code, but I don't have a clear enough overview of
+ ;; the compiler to know how to rearrange it all so that
+ ;; this operation fits in nicely, and it was blocking
+ ;; reimplementation of (DECLAIM (INLINE FOO)) (MACROLET
+ ;; ((..)) (DEFUN FOO ...))
+ ;;
+ ;; FIXME: This KLUDGE doesn't solve all the problem in an
+ ;; ideal way, as (1) definitions typed in at the REPL
+ ;; without an INLINE declaration will give a NULL
+ ;; FUNCTION-LAMBDA-EXPRESSION (allowable, but not ideal)
+ ;; and (2) INLINE declarations will yield a
+ ;; FUNCTION-LAMBDA-EXPRESSION headed by
+ ;; SB-C:LAMBDA-WITH-LEXENV, even for null LEXENV. -- CSR,
+ ;; 2002-07-02
+ ;;
+ ;; (2) is probably fairly easy to fix -- it is, after all,
+ ;; a matter of list manipulation (or possibly of teaching
+ ;; CL:FUNCTION about SB-C:LAMBDA-WITH-LEXENV). (1) is
+ ;; significantly harder, as the association between
+ ;; function object and source is a tricky one.
+ ;;
+ ;; FUNCTION-LAMBDA-EXPRESSION "works" (i.e. returns a
+ ;; non-NULL list) when the function in question has been
+ ;; compiled by (COMPILE <x> '(LAMBDA ...)); it does not
+ ;; work when it has been compiled as part of the top-level
+ ;; EVAL strategy of compiling everything inside (LAMBDA ()
+ ;; ...). -- CSR, 2002-11-02
+ (when (core-object-p *compile-object*)
+ (fix-core-source-info *source-info* *compile-object* result))
+
+ (mapc #'clear-ir1-info components-from-dfo))))))))
(defun process-toplevel-cold-fset (name lambda-expression path)
(unless (producing-fasl-file)
(%compile lambda-expression
*compile-object*
:name name
- :path path)
+ :path path)
*compile-object*)
(values))
(*print-level* 2)
(*print-pretty* nil))
(with-compiler-io-syntax
- (compiler-mumble "~&; ~:[compiling~;converting~] ~S"
- *block-compile* form)))
+ (compiler-mumble
+ #-sb-xc-host "~&; ~:[compiling~;converting~] ~S"
+ #+sb-xc-host "~&; ~:[x-compiling~;x-converting~] ~S"
+ *block-compile* form)))
form)
((and finalp
(eq :top-level-forms *compile-print*)
(t
*top-level-form-noted*))))
+;;; Handle the evaluation the a :COMPILE-TOPLEVEL body during
+;;; compilation. Normally just evaluate in the appropriate
+;;; environment, but also compile if outputting a CFASL.
+(defun eval-compile-toplevel (body path)
+ (eval-tlf `(progn ,@body) (source-path-tlf-number path) *lexenv*)
+ (when *compile-toplevel-object*
+ (let ((*compile-object* *compile-toplevel-object*))
+ (convert-and-maybe-compile `(progn ,@body) path))))
+
;;; Process a top level FORM with the specified source PATH.
;;; * If this is a magic top level form, then do stuff.
;;; * If this is a macro, then expand it.
(defun process-toplevel-form (form path compile-time-too)
(declare (list path))
- (catch 'process-toplevel-form-error-abort
- (let* ((path (or (gethash form *source-paths*) (cons form path)))
- (*compiler-error-bailout*
- (lambda (&optional condition)
- (convert-and-maybe-compile
- (make-compiler-error-form condition form)
- path)
- (throw 'process-toplevel-form-error-abort nil))))
+ (catch 'process-toplevel-form-error-abort
+ (let* ((path (or (get-source-path form) (cons form path)))
+ (*current-path* path)
+ (*compiler-error-bailout*
+ (lambda (&optional condition)
+ (convert-and-maybe-compile
+ (make-compiler-error-form condition form)
+ path)
+ (throw 'process-toplevel-form-error-abort nil))))
(flet ((default-processor (form)
(let ((*top-level-form-noted* (note-top-level-form form)))
(let ((expanded (preprocessor-macroexpand-1 form)))
(cond ((eq expanded form)
(when compile-time-too
- (eval-in-lexenv form *lexenv*))
+ (eval-compile-toplevel (list form) path))
(convert-and-maybe-compile form path))
(t
(process-toplevel-form expanded
;; (There are no xc EVAL-WHEN issues in the ATOM case until
;; (1) SBCL gets smart enough to handle global
;; DEFINE-SYMBOL-MACRO or SYMBOL-MACROLET and (2) SBCL
- ;; implementors start using symbol macros in a way which
- ;; interacts with SB-XC/CL distinction.)
+ ;; implementors start using symbol macros in a way which
+ ;; interacts with SB-XC/CL distinction.)
(convert-and-maybe-compile form path)
#-sb-xc-host
(default-processor form)
e))))
(cond (lt (process-toplevel-progn
body path new-compile-time-too))
- (new-compile-time-too (eval-in-lexenv
- `(progn ,@body)
- *lexenv*))))))
+ (new-compile-time-too
+ (eval-compile-toplevel body path))))))
((macrolet)
(funcall-in-macrolet-lexenv
magic
(lambda (&key funs prepend)
(declare (ignore funs))
- (aver (null prepend))
+ (aver (null prepend))
(process-toplevel-locally body
path
compile-time-too))
(funcall-in-symbol-macrolet-lexenv
magic
(lambda (&key vars prepend)
- (aver (null prepend))
+ (aver (null prepend))
(process-toplevel-locally body
path
compile-time-too
(fasl-dump-load-time-value-lambda lambda *compile-object*)
(let ((type (leaf-type lambda)))
(if (fun-type-p type)
- (single-value-type (fun-type-returns type))
- *wild-type*)))))
+ (single-value-type (fun-type-returns type))
+ *wild-type*)))))
;;; Compile the FORMS and arrange for them to be called (for effect,
;;; not value) at load time.
(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)))
(defun compile-load-time-value-lambda (lambdas)
(aver (null (cdr lambdas)))
(let* ((lambda (car lambdas))
- (component (lambda-component lambda)))
+ (component (lambda-component lambda)))
(when (eql (component-kind component) :toplevel)
(setf (component-name component) (leaf-debug-name lambda))
(compile-component component)
(declare (list lambdas))
(let ((len (length lambdas)))
(flet ((loser (start)
- (or (position-if (lambda (x)
- (not (eq (component-kind
- (node-component (lambda-bind x)))
- :toplevel)))
- lambdas
- ;; this used to read ":start start", but
- ;; start can be greater than len, which
- ;; is an error according to ANSI - CSR,
- ;; 2002-04-25
- :start (min start len))
- len)))
+ (or (position-if (lambda (x)
+ (not (eq (component-kind
+ (node-component (lambda-bind x)))
+ :toplevel)))
+ lambdas
+ ;; this used to read ":start start", but
+ ;; start can be greater than len, which
+ ;; is an error according to ANSI - CSR,
+ ;; 2002-04-25
+ :start (min start len))
+ len)))
(do* ((start 0 (1+ loser))
- (loser (loser start) (loser start)))
- ((>= start len))
- (sub-compile-toplevel-lambdas (subseq lambdas start loser))
- (unless (= loser len)
- (object-call-toplevel-lambda (elt lambdas loser))))))
+ (loser (loser start) (loser start)))
+ ((>= start len))
+ (sub-compile-toplevel-lambdas (subseq lambdas start loser))
+ (unless (= loser len)
+ (object-call-toplevel-lambda (elt lambdas loser))))))
(values))
;;; Compile LAMBDAS (a list of CLAMBDAs for top level forms) into the
-;;; object file.
+;;; object file.
;;;
;;; LOAD-TIME-VALUE-P seems to control whether it's MAKE-LOAD-FORM and
;;; COMPILE-LOAD-TIME-VALUE stuff. -- WHN 20000201
(defun compile-toplevel (lambdas load-time-value-p)
(declare (list lambdas))
-
+
(maybe-mumble "locall ")
(locall-analyze-clambdas-until-done lambdas)
(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*))
+ (maybe-mumble "[check]~%")
+ (check-ir1-consistency all-components))
(dolist (component (append hairy-top top-components))
- (pre-physenv-analyze-toplevel component))
+ (pre-physenv-analyze-toplevel component))
(dolist (component components)
- (compile-component component)
- (replace-toplevel-xeps component))
-
+ (compile-component component)
+ (replace-toplevel-xeps component))
+
(when *check-consistency*
- (maybe-mumble "[check]~%")
- (check-ir1-consistency *all-components*))
-
+ (maybe-mumble "[check]~%")
+ (check-ir1-consistency all-components))
+
(if load-time-value-p
- (compile-load-time-value-lambda lambdas)
- (compile-toplevel-lambdas lambdas))
+ (compile-load-time-value-lambda lambdas)
+ (compile-toplevel-lambdas lambdas))
- (mapc #'clear-ir1-info components)
- (clear-stuff)))
+ (mapc #'clear-ir1-info components)))
(values))
;;; Actually compile any stuff that has been queued up for block
(defun handle-condition-p (condition)
(let ((lexenv
- (etypecase *compiler-error-context*
- (node
- (node-lexenv *compiler-error-context*))
- (compiler-error-context
- (let ((lexenv (compiler-error-context-lexenv
- *compiler-error-context*)))
- (aver lexenv)
- lexenv))
- (null *lexenv*))))
+ (etypecase *compiler-error-context*
+ (node
+ (node-lexenv *compiler-error-context*))
+ (compiler-error-context
+ (let ((lexenv (compiler-error-context-lexenv
+ *compiler-error-context*)))
+ (aver lexenv)
+ lexenv))
+ (null *lexenv*))))
(let ((muffles (lexenv-handled-conditions lexenv)))
(if (null muffles) ; common case
- nil
- (dolist (muffle muffles nil)
- (destructuring-bind (typespec . restart-name) muffle
- (when (and (typep condition typespec)
- (find-restart restart-name condition))
- (return t))))))))
+ nil
+ (dolist (muffle muffles nil)
+ (destructuring-bind (typespec . restart-name) muffle
+ (when (and (typep condition typespec)
+ (find-restart restart-name condition))
+ (return t))))))))
(defun handle-condition-handler (condition)
(let ((lexenv
- (etypecase *compiler-error-context*
- (node
- (node-lexenv *compiler-error-context*))
- (compiler-error-context
- (let ((lexenv (compiler-error-context-lexenv
- *compiler-error-context*)))
- (aver lexenv)
- lexenv))
- (null *lexenv*))))
+ (etypecase *compiler-error-context*
+ (node
+ (node-lexenv *compiler-error-context*))
+ (compiler-error-context
+ (let ((lexenv (compiler-error-context-lexenv
+ *compiler-error-context*)))
+ (aver lexenv)
+ lexenv))
+ (null *lexenv*))))
(let ((muffles (lexenv-handled-conditions lexenv)))
(aver muffles)
(dolist (muffle muffles (bug "fell through"))
- (destructuring-bind (typespec . restart-name) muffle
- (when (typep condition typespec)
- (awhen (find-restart restart-name condition)
- (invoke-restart it))))))))
+ (destructuring-bind (typespec . restart-name) muffle
+ (when (typep condition typespec)
+ (awhen (find-restart restart-name condition)
+ (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*)
- (*handled-conditions* *handled-conditions*)
- (*disabled-package-locks* *disabled-package-locks*)
+ (*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))))
+ (lambda (&optional error)
+ (declare (ignore error))
+ (return-from sub-compile-file (values t t t))))
(*current-path* nil)
(*last-source-context* nil)
(*last-original-source* nil)
;; and it's not obvious whether the rebinding to itself is
;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*.
(*info-environment* *info-environment*)
- (*gensym-counter* 0))
+ (*compiler-sset-counter* 0)
+ (sb!xc:*gensym-counter* 0))
(handler-case
- (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
- (with-compilation-values
- (sb!xc:with-compilation-unit ()
- (clear-stuff)
-
- (sub-sub-compile-file info)
-
- (finish-block-compilation)
- (let ((object *compile-object*))
- (etypecase object
- (fasl-output (fasl-dump-source-info info object))
- (core-object (fix-core-source-info info object))
- (null)))
- nil)))
+ (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
+ (with-compilation-values
+ (sb!xc:with-compilation-unit ()
+ (with-world-lock ()
+ (sub-sub-compile-file info)
+ (unless (zerop (hash-table-count *code-coverage-records*))
+ ;; Dump the code coverage records into the fasl.
+ (with-source-paths
+ (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
+ (fasl-output (fasl-dump-source-info info object))
+ (core-object (fix-core-source-info info object))
+ (null)))
+ nil))))
;; Some errors are sufficiently bewildering that we just fail
;; immediately, without trying to recover and compile more of
;; the input file.
(fatal-compiler-error (condition)
(signal condition)
- (when *compile-verbose*
- (format *standard-output*
- "~@<compilation aborted because of fatal error: ~2I~_~A~:>"
- condition))
- (values nil t t)))))
+ (fresh-line *error-output*)
+ (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
+ (format *error-output*
+ "~@<~@:_compilation aborted because of fatal error: ~2I~_~A~@:_~:>"
+ (encapsulated-condition condition)))
+ (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* ((pathname (pathname pathname-designator))
- (default-host (make-pathname :host (pathname-host pathname))))
+ (default-host (make-pathname :host (pathname-host pathname))))
(flet ((try-with-type (path type error-p)
- (let ((new (merge-pathnames
- path (make-pathname :type type
- :defaults default-host))))
- (if (probe-file new)
- new
- (and error-p (truename new))))))
+ (let ((new (merge-pathnames
+ path (make-pathname :type type
+ :defaults default-host))))
+ (if (probe-file new)
+ new
+ (and error-p (truename new))))))
(cond ((typep pathname 'logical-pathname)
- (try-with-type pathname "LISP" t))
- ((probe-file pathname) pathname)
- ((try-with-type pathname "lisp" nil))
- ((try-with-type pathname "lisp" t))))))
-
-(defun elapsed-time-to-string (tsec)
- (multiple-value-bind (tmin sec) (truncate tsec 60)
- (multiple-value-bind (thr min) (truncate tmin 60)
- (format nil "~D:~2,'0D:~2,'0D" thr min sec))))
+ (try-with-type pathname "LISP" t))
+ ((probe-file pathname) pathname)
+ ((try-with-type pathname "lisp" nil))
+ ((try-with-type pathname "lisp" t))))))
+
+(defun elapsed-time-to-string (internal-time-delta)
+ (multiple-value-bind (tsec remainder)
+ (truncate internal-time-delta internal-time-units-per-second)
+ (let ((ms (truncate remainder (/ internal-time-units-per-second 1000))))
+ (multiple-value-bind (tmin sec) (truncate tsec 60)
+ (multiple-value-bind (thr min) (truncate tmin 60)
+ (format nil "~D:~2,'0D:~2,'0D.~3,'0D" thr min sec ms))))))
;;; Print some junk at the beginning and end of compilation.
(defun print-compile-start-note (source-info)
(declare (type source-info source-info))
(let ((file-info (source-info-file-info source-info)))
(compiler-mumble "~&; compiling file ~S (written ~A):~%"
- (namestring (file-info-name file-info))
- (sb!int:format-universal-time nil
- (file-info-write-date
- file-info)
- :style :government
- :print-weekday nil
- :print-timezone nil)))
+ (namestring (file-info-name file-info))
+ (sb!int:format-universal-time nil
+ (file-info-write-date
+ file-info)
+ :style :government
+ :print-weekday nil
+ :print-timezone nil)))
(values))
(defun print-compile-end-note (source-info won)
(declare (type source-info source-info))
(compiler-mumble "~&; compilation ~:[aborted after~;finished in~] ~A~&"
- won
- (elapsed-time-to-string
- (- (get-universal-time)
- (source-info-start-time source-info))))
+ won
+ (elapsed-time-to-string
+ (- (get-internal-real-time)
+ (source-info-start-real-time source-info))))
(values))
;;; Open some files and call SUB-COMPILE-FILE. If something unwinds
(external-format :default)
;; extensions
- (trace-file nil)
- ((:block-compile *block-compile-arg*) nil))
+ (trace-file nil)
+ ((:block-compile *block-compile-arg*) nil)
+ (emit-cfasl *emit-cfasl*))
#!+sb-doc
"Compile INPUT-FILE, producing a corresponding fasl file and
returning its filename.
:PRINT
- If true, a message per non-macroexpanded top level form is printed
+ If true, a message per non-macroexpanded top level form is printed
to *STANDARD-OUTPUT*. Top level forms that whose subforms are
processed as top level forms (eg. EVAL-WHEN, MACROLET, PROGN) receive
no such message, but their subforms do.
- As an extension to ANSI, if :PRINT is :top-level-forms, a message
- per top level form after macroexpansion is printed to *STANDARD-OUTPUT*.
+ As an extension to ANSI, if :PRINT is :top-level-forms, a message
+ per top level form after macroexpansion is printed to *STANDARD-OUTPUT*.
For example, compiling an IN-PACKAGE form will result in a message about
a top level SETQ in addition to the message about the IN-PACKAGE form'
itself.
:TRACE-FILE
If given, internal data structures are dumped to the specified
file, or if a value of T is given, to a file of *.trace type
- derived from the input file name. (non-standard)"
+ derived from the input file name. (non-standard)
+
+ :EMIT-CFASL
+ (Experimental). If true, outputs the toplevel compile-time effects
+ of this file into a separate .cfasl file."
;;; Block compilation is currently broken.
#|
"Also, as a workaround for vaguely-non-ANSI behavior, the
:BLOCK-COMPILE argument will probably become deprecated."
|#
(let* ((fasl-output nil)
- (output-file-name nil)
- (compile-won nil)
- (warnings-p nil)
- (failure-p t) ; T in case error keeps this from being set later
- (input-pathname (verify-source-file input-file))
- (source-info (make-file-source-info input-pathname external-format))
- (*compiler-trace-output* nil)) ; might be modified below
+ (cfasl-output nil)
+ (output-file-name nil)
+ (coutput-file-name 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))
+ (source-info (make-file-source-info input-pathname external-format))
+ (*compiler-trace-output* nil)) ; might be modified below
(unwind-protect
- (progn
- (when output-file
- (setq output-file-name
- (sb!xc:compile-file-pathname input-file
- :output-file output-file))
- (setq fasl-output
- (open-fasl-output output-file-name
- (namestring input-pathname))))
- (when trace-file
- (let* ((default-trace-file-pathname
- (make-pathname :type "trace" :defaults input-pathname))
- (trace-file-pathname
- (if (eql trace-file t)
- default-trace-file-pathname
- (merge-pathnames trace-file
- default-trace-file-pathname))))
- (setf *compiler-trace-output*
- (open trace-file-pathname
- :if-exists :supersede
- :direction :output))))
-
- (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))
+ (progn
+ (when output-file
+ (setq output-file-name
+ (sb!xc:compile-file-pathname input-file
+ :output-file output-file))
+ (setq fasl-output
+ (open-fasl-output output-file-name
+ (namestring input-pathname))))
+ (when emit-cfasl
+ (setq coutput-file-name
+ (make-pathname :type "cfasl"
+ :defaults output-file-name))
+ (setq cfasl-output
+ (open-fasl-output coutput-file-name
+ (namestring input-pathname))))
+ (when trace-file
+ (let* ((default-trace-file-pathname
+ (make-pathname :type "trace" :defaults input-pathname))
+ (trace-file-pathname
+ (if (eql trace-file t)
+ default-trace-file-pathname
+ (merge-pathnames trace-file
+ default-trace-file-pathname))))
+ (setf *compiler-trace-output*
+ (open trace-file-pathname
+ :if-exists :supersede
+ :direction :output))))
+
+ (when sb!xc:*compile-verbose*
+ (print-compile-start-note source-info))
+
+ (let ((*compile-object* fasl-output)
+ (*compile-toplevel-object* cfasl-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))
- (setq output-file-name
- (pathname (fasl-output-stream fasl-output)))
- (when (and compile-won sb!xc:*compile-verbose*)
- (compiler-mumble "~2&; ~A written~%" (namestring output-file-name))))
+ (close-fasl-output fasl-output abort-p)
+ (setq output-file-name
+ (pathname (fasl-output-stream fasl-output)))
+ (when (and (not abort-p) sb!xc:*compile-verbose*)
+ (compiler-mumble "~2&; ~A written~%" (namestring output-file-name))))
+
+ (when cfasl-output
+ (close-fasl-output cfasl-output abort-p)
+ (when (and (not abort-p) sb!xc:*compile-verbose*)
+ (compiler-mumble "; ~A written~%" (namestring coutput-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)
- warnings-p
- failure-p)))
+ (close *compiler-trace-output*)))
+
+ ;; 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
;;; a helper function for COMPILE-FILE-PATHNAME: the default for
;;; the OUTPUT-FILE argument
;;; compiled files.
(defun cfp-output-file-default (input-file)
(let* ((defaults (merge-pathnames input-file *default-pathname-defaults*))
- (retyped (make-pathname :type *fasl-file-type* :defaults defaults)))
+ (retyped (make-pathname :type *fasl-file-type* :defaults defaults)))
retyped))
-
+
;;; KLUDGE: Part of the ANSI spec for this seems contradictory:
;;; If INPUT-FILE is a logical pathname and OUTPUT-FILE is unsupplied,
;;; the result is a logical pathname. If INPUT-FILE is a logical
;;; physical pathname. Patches to make it more correct are welcome.
;;; -- WHN 2000-12-09
(defun sb!xc:compile-file-pathname (input-file
- &key
- (output-file (cfp-output-file-default
- input-file))
- &allow-other-keys)
+ &key
+ (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
(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
- ;; to rework DEF!STRUCT so that the MAKE-LOAD-FORM
- ;; function of LAYOUT returns nontrivial forms when
- ;; building the cross-compiler but :IGNORE-IT when
- ;; cross-compiling or running under the target Lisp. --
- ;; WHN 19990914
- #+sb-xc-host (typep constant 'layout))
+ ;; KLUDGE: This special hack is because I was too lazy
+ ;; to rework DEF!STRUCT so that the MAKE-LOAD-FORM
+ ;; function of LAYOUT returns nontrivial forms when
+ ;; building the cross-compiler but :IGNORE-IT when
+ ;; cross-compiling or running under the target Lisp. --
+ ;; WHN 19990914
+ #+sb-xc-host (typep constant 'layout))
(let ((circular-ref (assoc constant *constants-being-created* :test #'eq)))
(when circular-ref
- (when (find constant *constants-created-since-last-init* :test #'eq)
- (throw constant t))
- (throw 'pending-init circular-ref)))
+ (when (find constant *constants-created-since-last-init* :test #'eq)
+ (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*)
- t)
- (: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)
- (list constant))))
- (let ((*constants-being-created*
- (cons info *constants-being-created*))
- (*constants-created-since-last-init*
- (cons constant *constants-created-since-last-init*)))
- (when
- (catch constant
- (fasl-note-handle-for-constant
- constant
- (compile-load-time-value
- creation-form)
- *compile-object*)
- nil)
- (compiler-error "circular references in creation form for ~S"
- constant)))
- (when (cdr info)
- (let* ((*constants-created-since-last-init* nil)
- (circular-ref
- (catch 'pending-init
- (loop for (name form) on (cdr info) by #'cddr
- collect name into names
- collect form into forms
- finally (compile-make-load-form-init-forms forms))
- nil)))
- (when circular-ref
- (setf (cdr circular-ref)
- (append (cdr circular-ref) (cdr info))))))))))))
+ (:sb-just-dump-it-normally
+ (fasl-validate-structure constant *compile-object*)
+ t)
+ (:ignore-it
+ nil)
+ (t
+ (let* ((name (write-to-string constant :level 1 :length 2))
+ (info (if init-form
+ (list constant name init-form)
+ (list constant))))
+ (let ((*constants-being-created*
+ (cons info *constants-being-created*))
+ (*constants-created-since-last-init*
+ (cons constant *constants-created-since-last-init*)))
+ (when
+ (catch constant
+ (fasl-note-handle-for-constant
+ constant
+ (compile-load-time-value
+ creation-form)
+ *compile-object*)
+ nil)
+ (compiler-error "circular references in creation form for ~S"
+ constant)))
+ (when (cdr info)
+ (let* ((*constants-created-since-last-init* nil)
+ (circular-ref
+ (catch 'pending-init
+ (loop for (name form) on (cdr info) by #'cddr
+ collect name into names
+ collect form into forms
+ finally (compile-make-load-form-init-forms forms))
+ nil)))
+ (when circular-ref
+ (setf (cdr circular-ref)
+ (append (cdr circular-ref) (cdr info))))))))))))
\f
;;;; Host compile time definitions
(compile name lambda))
#+sb-xc-host
-(defun eval-in-lexenv (form lexenv)
- (declare (ignore lexenv))
+(defun eval-tlf (form index &optional lexenv)
+ (declare (ignore index lexenv))
(eval form))
projects / sbcl.git / blobdiff