[armedbear-cvs] r12226 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sun Oct 25 22:35:53 UTC 2009
Author: ehuelsmann
Date: Sun Oct 25 18:35:52 2009
New Revision: 12226
Log:
Binary FASL support.
compile-file.lisp: Catch forms for output and compile them.
compiler-pass2.lisp: Allow fields to be declared in-line
which means they are part of the evaluation of the compiled function,
instead of in its constructor - where constants will still be constructed.
Modified:
trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Oct 25 18:35:52 2009
@@ -76,8 +76,8 @@
(declare (ignore classfile))
t)
-(declaim (ftype (function (t stream) t) process-defconstant))
-(defun process-defconstant (form stream)
+(declaim (ftype (function (t) t) process-defconstant))
+(defun process-defconstant (form)
;; "If a DEFCONSTANT form appears as a top level form, the compiler
;; must recognize that [the] name names a constant variable. An
;; implementation may choose to evaluate the value-form at compile
@@ -86,8 +86,7 @@
;; whether or not references to name appear in the file) and that
;; it always evaluates to the same value."
(eval form)
- (dump-form form stream)
- (%stream-terpri stream))
+ (output-form form))
(declaim (ftype (function (t) t) note-toplevel-form))
(defun note-toplevel-form (form)
@@ -117,8 +116,7 @@
(eval form)
;; Force package prefix to be used when dumping form.
(let ((*package* +keyword-package+))
- (dump-form form stream))
- (%stream-terpri stream)
+ (output-form form))
(return-from process-toplevel-form))
((DEFVAR DEFPARAMETER)
(note-toplevel-form form)
@@ -133,7 +131,7 @@
(%defvar name))))
(DEFCONSTANT
(note-toplevel-form form)
- (process-defconstant form stream)
+ (process-defconstant form)
(return-from process-toplevel-form))
(DEFUN
(note-toplevel-form form)
@@ -154,7 +152,7 @@
:if-exists :supersede)
(report-error
(jvm:compile-defun name expr nil
- classfile f))))
+ classfile f nil))))
(compiled-function (verify-load classfile)))
(declare (ignore result))
(cond
@@ -187,10 +185,8 @@
(setf (inline-expansion name)
(jvm::generate-inline-expansion block-name
lambda-list body))
- (dump-form `(setf (inline-expansion ',name)
- ',(inline-expansion name))
- stream)
- (%stream-terpri stream))))
+ (output-form `(setf (inline-expansion ',name)
+ ',(inline-expansion name))))))
(push name jvm::*functions-defined-in-current-file*)
(note-name-defined name)
;; If NAME is not fbound, provide a dummy definition so that
@@ -218,7 +214,7 @@
:element-type '(unsigned-byte 8)
:if-exists :supersede)
(ignore-errors
- (jvm:compile-defun nil expr nil classfile f)))
+ (jvm:compile-defun nil expr nil classfile f nil)))
(if (null (verify-load classfile))
;; FIXME error or warning
(format *error-output* "; Unable to compile macro ~A~%" name)
@@ -299,8 +295,7 @@
(setf form (precompiler:precompile-form form nil *compile-file-environment*))
;; Make sure package prefix is printed when symbols are imported.
(let ((*package* +keyword-package+))
- (dump-form form stream))
- (%stream-terpri stream)
+ (output-form form))
(when compile-time-too
(eval form))
(return-from process-toplevel-form))
@@ -326,10 +321,9 @@
(t
;;; (setf form (precompiler:precompile-form form nil))
(note-toplevel-form form)
- (setf form (convert-toplevel-form form)))))))))
+ (setf form (convert-toplevel-form form nil)))))))))
(when (consp form)
- (dump-form form stream)
- (%stream-terpri stream))
+ (output-form form))
;; Make sure the compiled-function loader knows where
;; to load the compiled functions. Note that this trickery
;; was already used in verify-load before I used it,
@@ -360,7 +354,7 @@
:element-type '(unsigned-byte 8)
:if-exists :supersede)
(report-error
- (jvm:compile-defun nil lambda-expression nil classfile f))))
+ (jvm:compile-defun nil lambda-expression nil classfile f nil))))
(compiled-function (verify-load classfile)))
(declare (ignore result))
(cond (compiled-function
@@ -375,12 +369,12 @@
"Returns NIL if the form is too complex to become an
interpreted toplevel form, non-NIL if it is 'simple enough'."
(and (consp form)
- (every #'(lambda (arg)
- (or (and (atom arg)
- (not (and (symbolp arg)
- (symbol-macro-p arg))))
- (and (consp arg)
- (eq 'QUOTE (car arg)))))
+ (every #'(lambda (arg)
+ (or (and (atom arg)
+ (not (and (symbolp arg)
+ (symbol-macro-p arg))))
+ (and (consp arg)
+ (eq 'QUOTE (car arg)))))
(cdr form))))
(declaim (ftype (function (t) t) convert-toplevel-form))
@@ -405,7 +399,8 @@
:direction :output
:element-type '(unsigned-byte 8)
:if-exists :supersede)
- (report-error (jvm:compile-defun nil expr nil classfile f))))
+ (report-error (jvm:compile-defun nil expr nil classfile
+ f declare-inline))))
(compiled-function (verify-load classfile)))
(declare (ignore result))
(setf form
@@ -447,13 +442,35 @@
(intersection '(:load-toplevel load) situations)
(intersection '(:execute eval) situations)))
+
+(defvar *binary-fasls* nil)
+(defvar *forms-for-output* nil)
+(defvar *fasl-stream* nil)
+
+(defun output-form (form)
+ (if *binary-fasls*
+ (push form *forms-for-output*)
+ (progn
+ (dump-form form *fasl-stream*)
+ (%stream-terpri *fasl-stream*))))
+
+(defun finalize-fasl-output ()
+ (when *binary-fasls*
+ (let ((*package* (find-package :keyword))
+ (*double-colon-package-separators* T))
+ (dump-form (convert-toplevel-form (list* 'PROGN
+ (nreverse *forms-for-output*))
+ t)
+ *fasl-stream*))
+ (%stream-terpri *fasl-stream*)))
+
(defun compile-file (input-file
&key
output-file
((:verbose *compile-verbose*) *compile-verbose*)
((:print *compile-print*) *compile-print*)
external-format)
- (declare (ignore external-format)) ; FIXME
+ (declare (ignore external-format)) ; FIXME
(unless (or (and (probe-file input-file) (not (file-directory-p input-file)))
(pathname-type input-file))
(let ((pathname (merge-pathnames (make-pathname :type "lisp") input-file)))
@@ -487,42 +504,45 @@
(*package* *package*)
(jvm::*functions-defined-in-current-file* '())
(*fbound-names* '())
- (*fasl-anonymous-package* (%make-package)))
+ (*fasl-anonymous-package* (%make-package))
+ (*fasl-stream* out)
+ *forms-for-output*)
(jvm::with-saved-compiler-policy
- (jvm::with-file-compilation
- (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
- (%stream-terpri out)
- (let ((*package* (find-package '#:cl)))
- (write (list 'init-fasl :version *fasl-version*)
- :stream out)
+ (jvm::with-file-compilation
+ (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
(%stream-terpri out)
- (write (list 'setq '*source* *compile-file-truename*)
- :stream out)
- (%stream-terpri out))
- (handler-bind ((style-warning #'(lambda (c)
- (setf warnings-p t)
- ;; let outer handlers
- ;; do their thing
- (signal c)
- ;; prevent the next
- ;; handler from running:
- ;; we're a WARNING subclass
- (continue)))
- ((or warning
- compiler-error) #'(lambda (c)
- (declare (ignore c))
- (setf warnings-p t
- failure-p t))))
- (loop
- (let* ((*source-position* (file-position in))
- (jvm::*source-line-number* (stream-line-number in))
- (form (read in nil in))
- (*compiler-error-context* form))
- (when (eq form in)
- (return))
- (process-toplevel-form form out nil))))
- (dolist (name *fbound-names*)
- (fmakunbound name)))))))
+ (let ((*package* (find-package '#:cl)))
+ (write (list 'init-fasl :version *fasl-version*)
+ :stream out)
+ (%stream-terpri out)
+ (write (list 'setq '*source* *compile-file-truename*)
+ :stream out)
+ (%stream-terpri out))
+ (handler-bind ((style-warning #'(lambda (c)
+ (setf warnings-p t)
+ ;; let outer handlers
+ ;; do their thing
+ (signal c)
+ ;; prevent the next
+ ;; handler from running:
+ ;; we're a WARNING subclass
+ (continue)))
+ ((or warning
+ compiler-error) #'(lambda (c)
+ (declare (ignore c))
+ (setf warnings-p t
+ failure-p t))))
+ (loop
+ (let* ((*source-position* (file-position in))
+ (jvm::*source-line-number* (stream-line-number in))
+ (form (read in nil in))
+ (*compiler-error-context* form))
+ (when (eq form in)
+ (return))
+ (process-toplevel-form form out nil))))
+ (finalize-fasl-output)
+ (dolist (name *fbound-names*)
+ (fmakunbound name)))))))
(rename-file temp-file output-file)
(when *compile-file-zip*
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Oct 25 18:35:52 2009
@@ -1948,6 +1948,8 @@
(when (plusp (length output))
output)))
+(defvar *declare-inline* nil)
+
(defmacro declare-with-hashtable (declared-item hashtable hashtable-var
item-var &body body)
`(let* ((,hashtable-var ,hashtable)
@@ -1970,19 +1972,19 @@
(declare-object symbol +lisp-symbol+
+lisp-symbol-class+))))
(t
- (let ((*code* *static-code*)
- (s (sanitize symbol)))
- (setf g (symbol-name (gensym "SYM")))
- (when s
- (setf g (concatenate 'string g "_" s)))
- (declare-field g +lisp-symbol+ +field-access-private+)
- (emit 'ldc (pool-string (symbol-name symbol)))
- (emit 'ldc (pool-string (package-name (symbol-package symbol))))
- (emit-invokestatic +lisp-class+ "internInPackage"
- (list +java-string+ +java-string+) +lisp-symbol+)
- (emit 'putstatic *this-class* g +lisp-symbol+)
- (setf *static-code* *code*)
- (setf (gethash symbol ht) g))))))
+ (let ((*code* *static-code*)
+ (s (sanitize symbol)))
+ (setf g (symbol-name (gensym "SYM")))
+ (when s
+ (setf g (concatenate 'string g "_" s)))
+ (declare-field g +lisp-symbol+ +field-access-private+)
+ (emit 'ldc (pool-string (symbol-name symbol)))
+ (emit 'ldc (pool-string (package-name (symbol-package symbol))))
+ (emit-invokestatic +lisp-class+ "internInPackage"
+ (list +java-string+ +java-string+) +lisp-symbol+)
+ (emit 'putstatic *this-class* g +lisp-symbol+)
+ (setf *static-code* *code*)
+ (setf (gethash symbol ht) g))))))
(defun lookup-or-declare-symbol (symbol)
"Returns the value-pair (VALUES field class) from which
@@ -2000,6 +2002,9 @@
(declare-with-hashtable
symbol *declared-symbols* ht g
(let ((*code* *static-code*))
+ ;; there's no requirement to declare-inline here:
+ ;; keywords are constants, so they can be created any time,
+ ;; if early enough
(setf g (symbol-name (gensym "KEY")))
(declare-field g +lisp-symbol+ +field-access-private+)
(emit 'ldc (pool-string (symbol-name symbol)))
@@ -2022,16 +2027,22 @@
(multiple-value-bind
(name class)
(lookup-or-declare-symbol symbol)
- (let ((*code* *static-code*))
- (emit 'getstatic class name +lisp-symbol+)
- (emit-invokevirtual +lisp-symbol-class+
- (if setf
- "getSymbolSetfFunctionOrDie"
- "getSymbolFunctionOrDie")
- nil +lisp-object+)
- (emit 'putstatic *this-class* f +lisp-object+)
- (setf *static-code* *code*)
- (setf (gethash symbol ht) f)))))
+ (let (saved-code)
+ (let ((*code* (if *declare-inline* *code* *static-code*)))
+ (emit 'getstatic class name +lisp-symbol+)
+ (emit-invokevirtual +lisp-symbol-class+
+ (if setf
+ "getSymbolSetfFunctionOrDie"
+ "getSymbolFunctionOrDie")
+ nil +lisp-object+)
+ (emit 'putstatic *this-class* f +lisp-object+)
+ (if *declare-inline*
+ (setf saved-code *code*)
+ (setf *static-code* *code*))
+ (setf (gethash symbol ht) f))
+ (when *declare-inline*
+ (setf *code* saved-code))
+ f))))
(defknown declare-setf-function (name) string)
(defun declare-setf-function (name)
@@ -2045,6 +2056,7 @@
(setf g (symbol-name (gensym "LFUN")))
(let* ((pathname (class-file-pathname (local-function-class-file local-function)))
(*code* *static-code*))
+ ;; fixme *declare-inline*
(declare-field g +lisp-object+ +field-access-default+)
(emit 'ldc (pool-string (file-namestring pathname)))
(emit-invokestatic +lisp-class+ "loadCompiledFunction"
@@ -2059,6 +2071,7 @@
(declare-with-hashtable
n *declared-integers* ht g
(let ((*code* *static-code*))
+ ;; no need to *declare-inline*: constants
(setf g (format nil "FIXNUM_~A~D"
(if (minusp n) "MINUS_" "")
(abs n)))
@@ -2080,6 +2093,7 @@
n *declared-integers* ht g
(setf g (concatenate 'string "BIGNUM_" (symbol-name (gensym))))
(let ((*code* *static-code*))
+ ;; no need to *declare-inline*: constants
(declare-field g +lisp-integer+ +field-access-private+)
(cond ((<= most-negative-java-long n most-positive-java-long)
;; (setf g (format nil "BIGNUM_~A~D"
@@ -2104,6 +2118,7 @@
(declare-with-hashtable
s *declared-floats* ht g
(let* ((*code* *static-code*))
+ ;; no need to *declare-inline*: constants
(setf g (concatenate 'string "FLOAT_" (symbol-name (gensym))))
(declare-field g +lisp-single-float+ +field-access-private+)
(emit 'new +lisp-single-float-class+)
@@ -2119,6 +2134,7 @@
(declare-with-hashtable
d *declared-doubles* ht g
(let ((*code* *static-code*))
+ ;; no need to *declare-inline*: constants
(setf g (concatenate 'string "DOUBLE_" (symbol-name (gensym))))
(declare-field g +lisp-double-float+ +field-access-private+)
(emit 'new +lisp-double-float-class+)
@@ -2134,6 +2150,7 @@
(let ((g (symbol-name (gensym "CHAR")))
(n (char-code c))
(*code* *static-code*))
+ ;; no need to *declare-inline*: constants
(declare-field g +lisp-character+ +field-access-private+)
(cond ((<= 0 n 255)
(emit 'getstatic +lisp-character-class+ "constants" +lisp-character-array+)
@@ -2151,23 +2168,31 @@
(defknown declare-object-as-string (t &optional t) string)
(defun declare-object-as-string (obj &optional (obj-ref +lisp-object+)
obj-class)
- (let* ((g (symbol-name (gensym "OBJSTR")))
- (s (with-output-to-string (stream) (dump-form obj stream)))
- (*code* *static-code*))
- (declare-field g obj-ref +field-access-private+)
- (emit 'ldc (pool-string s))
- (emit-invokestatic +lisp-class+ "readObjectFromString"
- (list +java-string+) +lisp-object+)
- (when (and obj-class (string/= obj-class +lisp-object+))
- (emit 'checkcast obj-class))
- (emit 'putstatic *this-class* g obj-ref)
- (setf *static-code* *code*)
+ (let (saved-code
+ (g (symbol-name (gensym "OBJSTR"))))
+ (let* ((s (with-output-to-string (stream) (dump-form obj stream)))
+ (*code* (if *declare-inline* *code* *static-code*)))
+ ;; strings may contain evaluated bits which may depend on
+ ;; previous statements
+ (declare-field g obj-ref +field-access-private+)
+ (emit 'ldc (pool-string s))
+ (emit-invokestatic +lisp-class+ "readObjectFromString"
+ (list +java-string+) +lisp-object+)
+ (when (and obj-class (string/= obj-class +lisp-object+))
+ (emit 'checkcast obj-class))
+ (emit 'putstatic *this-class* g obj-ref)
+ (if *declare-inline*
+ (setf saved-code *code*)
+ (setf *static-code* *code*)))
+ (when *declare-inline*
+ (setf *code* saved-code))
g))
(defun declare-load-time-value (obj)
(let* ((g (symbol-name (gensym "LTV")))
(s (with-output-to-string (stream) (dump-form obj stream)))
(*code* *static-code*))
+ ;; fixme *declare-inline*?
(declare-field g +lisp-object+ +field-access-private+)
(emit 'ldc (pool-string s))
(emit-invokestatic +lisp-class+ "readObjectFromString"
@@ -2186,6 +2211,7 @@
(let* ((g (symbol-name (gensym "INSTANCE")))
(s (with-output-to-string (stream) (dump-form obj stream)))
(*code* *static-code*))
+ ;; fixme *declare-inline*?
(declare-field g +lisp-object+ +field-access-private+)
(emit 'ldc (pool-string s))
(emit-invokestatic +lisp-class+ "readObjectFromString"
@@ -2197,17 +2223,22 @@
g))
(defun declare-package (obj)
- (let* ((g (symbol-name (gensym "PKG")))
- (*print-level* nil)
- (*print-length* nil)
- (s (format nil "#.(FIND-PACKAGE ~S)" (package-name obj)))
- (*code* *static-code*))
- (declare-field g +lisp-object+ +field-access-private+)
- (emit 'ldc (pool-string s))
- (emit-invokestatic +lisp-class+ "readObjectFromString"
- (list +java-string+) +lisp-object+)
- (emit 'putstatic *this-class* g +lisp-object+)
- (setf *static-code* *code*)
+ (let (saved-code
+ (g (symbol-name (gensym "PKG"))))
+ (let* ((*print-level* nil)
+ (*print-length* nil)
+ (s (format nil "#.(FIND-PACKAGE ~S)" (package-name obj)))
+ (*code* *static-code*))
+ (declare-field g +lisp-object+ +field-access-private+)
+ (emit 'ldc (pool-string s))
+ (emit-invokestatic +lisp-class+ "readObjectFromString"
+ (list +java-string+) +lisp-object+)
+ (emit 'putstatic *this-class* g +lisp-object+)
+ (if *declare-inline*
+ (setf saved-code *code*)
+ (setf *static-code* *code*)))
+ (when *declare-inline*
+ (setf *code* saved-code))
g))
(declaim (ftype (function (t &optional t) string) declare-object))
@@ -2218,6 +2249,7 @@
The field type of the object is specified by OBJ-REF."
(let ((key (symbol-name (gensym "OBJ"))))
+ ;; fixme *declare-inline*?
(remember key obj)
(let* ((g1 (declare-string key))
(g2 (symbol-name (gensym "O2BJ"))))
@@ -2233,35 +2265,41 @@
g2))))
(defun declare-lambda (obj)
- (let* ((g (symbol-name (gensym "LAMBDA")))
- (*print-level* nil)
- (*print-length* nil)
- (s (format nil "~S" obj))
- (*code* *static-code*))
- (declare-field g +lisp-object+ +field-access-private+)
- (emit 'ldc
- (pool-string s))
- (emit-invokestatic +lisp-class+ "readObjectFromString"
- (list +java-string+) +lisp-object+)
- (emit-invokestatic +lisp-class+ "coerceToFunction"
- (lisp-object-arg-types 1) +lisp-object+)
- (emit 'putstatic *this-class* g +lisp-object+)
- (setf *static-code* *code*)
+ (let (saved-code
+ (g (symbol-name (gensym "LAMBDA"))))
+ (let* ((*print-level* nil)
+ (*print-length* nil)
+ (s (format nil "~S" obj))
+ (*code* *static-code*))
+ (declare-field g +lisp-object+ +field-access-private+)
+ (emit 'ldc
+ (pool-string s))
+ (emit-invokestatic +lisp-class+ "readObjectFromString"
+ (list +java-string+) +lisp-object+)
+ (emit-invokestatic +lisp-class+ "coerceToFunction"
+ (lisp-object-arg-types 1) +lisp-object+)
+ (emit 'putstatic *this-class* g +lisp-object+)
+ (if *declare-inline*
+ (setf saved-code *code*)
+ (setf *static-code* *code*)))
+ (when *declare-inline*
+ (setf *code* saved-code))
g))
(defun declare-string (string)
(declare-with-hashtable
string *declared-strings* ht g
(let ((*code* *static-code*))
- (setf g (symbol-name (gensym "STR")))
- (declare-field g +lisp-simple-string+ +field-access-private+)
- (emit 'new +lisp-simple-string-class+)
- (emit 'dup)
- (emit 'ldc (pool-string string))
- (emit-invokespecial-init +lisp-simple-string-class+ (list +java-string+))
- (emit 'putstatic *this-class* g +lisp-simple-string+)
- (setf *static-code* *code*)
- (setf (gethash string ht) g))))
+ ;; constant: no need to *declare-inline*
+ (setf g (symbol-name (gensym "STR")))
+ (declare-field g +lisp-simple-string+ +field-access-private+)
+ (emit 'new +lisp-simple-string-class+)
+ (emit 'dup)
+ (emit 'ldc (pool-string string))
+ (emit-invokespecial-init +lisp-simple-string-class+ (list +java-string+))
+ (emit 'putstatic *this-class* g +lisp-simple-string+)
+ (setf *static-code* *code*)
+ (setf (gethash string ht) g))))
(defknown compile-constant (t t t) t)
(defun compile-constant (form target representation)
@@ -8448,7 +8486,7 @@
`(lambda ,(cadr form)
(error 'program-error :format-control "Execution of a form compiled with errors.")))
-(defun compile-defun (name form environment filespec stream)
+(defun compile-defun (name form environment filespec stream *declare-inline*)
"Compiles a lambda expression `form'. If `filespec' is NIL,
a random Java class name is generated, if it is non-NIL, it's used
to derive a Java class name from."
@@ -8572,7 +8610,7 @@
(setf compiled-function
(load-compiled-function
(with-open-stream (s (sys::%make-byte-array-output-stream))
- (compile-defun name expr env nil s)
+ (compile-defun name expr env nil s nil)
(finish-output s)
(sys::%get-output-stream-bytes s))))))
(when (and name (functionp compiled-function))
More information about the armedbear-cvs
mailing list