Update of /cvsroot/sbcl/sbcl/src/compiler
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv2287/src/compiler
Modified Files:
dump.lisp ir1tran-lambda.lisp main.lisp
Log Message:
1.0.30.4: cfasl support
Experimental support for compiling any toplevel compile-time
effects to a separate cfasl file, in addition to evaluating
them.
* Open a second fasl output stream if :EMIT-CFASL is passed to
COMPILE-FILE. In the places where we'd normally evaluate the body
of a EVAL-WHEN :COMPILE-TOPLEVEL do both the evaluation and do a
normal compilation of the form, with the output going to the second
fasl stream.
* Fix a couple of places where a %compiler-defun would assume it'd
never be called outside the compiler (now it can be called during
cfasl loading).
* Remove the timestamps from the human-readable fasl header. They're
not really useful for anything, and make the cfasls less deterministic
and thus less useful.
Index: dump.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/dump.lisp,v
retrieving revision 1.72
retrieving revision 1.73
diff -u -d -r1.72 -r1.73
--- dump.lisp 21 Jun 2009 16:30:33 -0000 1.72
+++ dump.lisp 20 Jul 2009 04:26:31 -0000 1.73
@@ -318,14 +318,8 @@
(format nil
"~% ~
compiled from ~S~% ~
- at ~A~% ~
- on ~A~% ~
using ~A version ~A~%"
where
- #+sb-xc-host "cross-compile time"
- #-sb-xc-host (format-universal-time nil (get-universal-time))
- #+sb-xc-host "cross-compile host"
- #-sb-xc-host (machine-instance)
(sb!xc:lisp-implementation-type)
(sb!xc:lisp-implementation-version))))
stream)
Index: ir1tran-lambda.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran-lambda.lisp,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -d -r1.47 -r1.48
--- ir1tran-lambda.lisp 21 Jun 2009 10:26:25 -0000 1.47
+++ ir1tran-lambda.lisp 20 Jul 2009 04:26:31 -0000 1.48
@@ -1078,24 +1078,25 @@
;;; 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
@@ -1162,14 +1163,13 @@
(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)
Index: main.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/main.lisp,v
retrieving revision 1.145
retrieving revision 1.146
diff -u -d -r1.145 -r1.146
--- main.lisp 28 Jun 2009 21:37:05 -0000 1.145
+++ main.lisp 20 Jul 2009 04:26:31 -0000 1.146
@@ -114,6 +114,9 @@
(defvar *compile-object* nil)
(declaim (type object *compile-object*))
+(defvar *compile-toplevel-object* nil)
+
+(defvar *emit-cfasl* nil)
(defvar *fopcompile-label-counter*)
@@ -1199,6 +1202,15 @@
(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.
@@ -1278,7 +1290,7 @@
(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
@@ -1324,9 +1336,8 @@
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
@@ -1683,7 +1694,8 @@
;; 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.
@@ -1709,7 +1721,11 @@
: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
@@ -1726,7 +1742,9 @@
: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
@@ -1743,6 +1761,13 @@
(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))
@@ -1759,7 +1784,8 @@
(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))))
@@ -1772,6 +1798,11 @@
(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)))
|