;;; previous references.
(defun get-defined-fun (name)
(proclaim-as-fun-name name)
- (let ((found (find-free-fun name "shouldn't happen! (defined-fun)")))
- (note-name-defined name :function)
- (cond ((not (defined-fun-p found))
- (aver (not (info :function :inlinep name)))
- (let* ((where-from (leaf-where-from found))
- (res (make-defined-fun
- :%source-name name
- :where-from (if (eq where-from :declared)
- :declared :defined)
- :type (leaf-type found))))
- (substitute-leaf res found)
- (setf (gethash name *free-funs*) res)))
- ;; If *FREE-FUNS* has a previously converted definition
- ;; for this name, then blow it away and try again.
- ((defined-fun-functionals found)
- (remhash name *free-funs*)
- (get-defined-fun name))
- (t found))))
+ (when (boundp '*free-funs*)
+ (let ((found (find-free-fun name "shouldn't happen! (defined-fun)")))
+ (note-name-defined name :function)
+ (cond ((not (defined-fun-p found))
+ (aver (not (info :function :inlinep name)))
+ (let* ((where-from (leaf-where-from found))
+ (res (make-defined-fun
+ :%source-name name
+ :where-from (if (eq where-from :declared)
+ :declared :defined)
+ :type (leaf-type found))))
+ (substitute-leaf res found)
+ (setf (gethash name *free-funs*) res)))
+ ;; If *FREE-FUNS* has a previously converted definition
+ ;; for this name, then blow it away and try again.
+ ((defined-fun-functionals found)
+ (remhash name *free-funs*)
+ (get-defined-fun name))
+ (t found)))))
;;; Check a new global function definition for consistency with
;;; previous declaration or definition, and assert argument/result
(defun %compiler-defun (name lambda-with-lexenv compile-toplevel)
(let ((defined-fun nil)) ; will be set below if we're in the compiler
(when compile-toplevel
- ;; better be in the compiler
- (aver (boundp '*lexenv*))
- (remhash name *free-funs*)
(setf defined-fun (get-defined-fun name))
- (aver (fasl-output-p *compile-object*))
- (if (member name *fun-names-in-this-file* :test #'equal)
- (warn 'duplicate-definition :name name)
- (push name *fun-names-in-this-file*)))
+ (when (boundp '*lexenv*)
+ (remhash name *free-funs*)
+ (aver (fasl-output-p *compile-object*))
+ (if (member name *fun-names-in-this-file* :test #'equal)
+ (warn 'duplicate-definition :name name)
+ (push name *fun-names-in-this-file*))))
(become-defined-fun-name name)
(defvar *compile-object* nil)
(declaim (type object *compile-object*))
+(defvar *compile-toplevel-object* nil)
+
+(defvar *emit-cfasl* nil)
(defvar *fopcompile-label-counter*)
(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-in-lexenv `(progn ,@body) *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
;; 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)))
projects / sbcl.git / commitdiff