(defvar *compile-object* nil)
(declaim (type object *compile-object*))
+(defvar *compile-toplevel-object* nil)
+
+(defvar *emit-cfasl* nil)
(defvar *fopcompile-label-counter*)
(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.
-
- :SOURCE-PLIST Plist-Form
- Attaches the value returned by the Plist-Form to internal debug-source
- information of functions compiled in within the dynamic contour.
- Primarily for use by development environments, in order to eg. associate
- function definitions with editor-buffers. Can be accessed as
- SB-INTROSPECT:DEFINITION-SOURCE-PLIST. If multiple, nested
- WITH-COMPILATION-UNITs provide :SOURCE-PLISTs, they are appended
- togather, innermost left. If Unaffected by :OVERRIDE."
+ "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))
(defvar *source-plist* nil)
+(defvar *source-namestring* nil)
-(defun %with-compilation-unit (fn &key override source-plist)
+(defun %with-compilation-unit (fn &key override policy source-plist source-namestring)
(declare (type function fn))
- (let ((succeeded-p nil)
- (*source-plist* (append source-plist *source-plist*)))
- (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))
- (with-world-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)))))))))
+ (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))
+ (with-world-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))))))))))
+ (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 %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 ")
(print-unreadable-object (s stream :type t))))
(:copier nil))
;; the UT that compilation started at
- (start-time (get-internal-real-time) :type unsigned-byte)
+ (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
;;; 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)
(source-name (or name '.anonymous.)))
(setf (component-name component) (debug-name 'initial-component debug-name-tail)
(component-kind component) :initial)
- (let* ((locall-fun (let ((*allow-instrumenting* t))
- (funcall #'ir1-convert-lambdalike
- 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)
+ (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 locall-fun) t
- (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.
(*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.
(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
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
;; the input file.
(fatal-compiler-error (condition)
(signal condition)
+ (fresh-line *error-output*)
(pprint-logical-block (*error-output* nil :per-line-prefix "; ")
(format *error-output*
- "~@<compilation aborted because of fatal error: ~2I~_~A~:>"
- condition))
+ "~@<~@:_compilation aborted because of fatal error: ~2I~_~A~@:_~:>"
+ (encapsulated-condition condition)))
(finish-output *error-output*)
(values t t t)))))
won
(elapsed-time-to-string
(- (get-internal-real-time)
- (source-info-start-time source-info))))
+ (source-info-start-real-time source-info))))
(values))
;;; Open some files and call SUB-COMPILE-FILE. If something unwinds
;; extensions
(trace-file nil)
- ((:block-compile *block-compile-arg*) 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.
: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)
+ (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
(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))
(when sb!xc:*compile-verbose*
(print-compile-start-note source-info))
- (let ((*compile-object* fasl-output))
+ (let ((*compile-object* fasl-output)
+ (*compile-toplevel-object* cfasl-output))
(setf (values abort-p warnings-p failure-p)
(sub-compile-file source-info))))
(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 (not abort-p)))
(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