Changeset 12226


Ignore:
Timestamp:
10/25/09 22:35:52 (12 years ago)
Author:
ehuelsmann
Message:

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.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compile-file.lisp

    r12220 r12226  
    7777  t)
    7878
    79 (declaim (ftype (function (t stream) t) process-defconstant))
    80 (defun process-defconstant (form stream)
     79(declaim (ftype (function (t) t) process-defconstant))
     80(defun process-defconstant (form)
    8181  ;; "If a DEFCONSTANT form appears as a top level form, the compiler
    8282  ;; must recognize that [the] name names a constant variable. An
     
    8787  ;; it always evaluates to the same value."
    8888  (eval form)
    89   (dump-form form stream)
    90   (%stream-terpri stream))
     89  (output-form form))
    9190
    9291(declaim (ftype (function (t) t) note-toplevel-form))
     
    118117           ;; Force package prefix to be used when dumping form.
    119118           (let ((*package* +keyword-package+))
    120              (dump-form form stream))
    121            (%stream-terpri stream)
     119             (output-form form))
    122120           (return-from process-toplevel-form))
    123121          ((DEFVAR DEFPARAMETER)
     
    134132          (DEFCONSTANT
    135133           (note-toplevel-form form)
    136            (process-defconstant form stream)
     134           (process-defconstant form)
    137135           (return-from process-toplevel-form))
    138136          (DEFUN
     
    155153          (report-error
    156154           (jvm:compile-defun name expr nil
    157                   classfile f))))
     155                  classfile f nil))))
    158156                        (compiled-function (verify-load classfile)))
    159157       (declare (ignore result))
     
    188186                         (jvm::generate-inline-expansion block-name
    189187                                                         lambda-list body))
    190                    (dump-form `(setf (inline-expansion ',name)
    191                                      ',(inline-expansion name))
    192                               stream)
    193                    (%stream-terpri stream))))
     188                   (output-form `(setf (inline-expansion ',name)
     189                                       ',(inline-expansion name))))))
    194190             (push name jvm::*functions-defined-in-current-file*)
    195191             (note-name-defined name)
     
    219215          :if-exists :supersede)
    220216     (ignore-errors
    221        (jvm:compile-defun nil expr nil classfile f)))
     217       (jvm:compile-defun nil expr nil classfile f nil)))
    222218               (if (null (verify-load classfile))
    223219                   ;; FIXME error or warning
     
    300296                  ;; Make sure package prefix is printed when symbols are imported.
    301297                  (let ((*package* +keyword-package+))
    302                     (dump-form form stream))
    303                   (%stream-terpri stream)
     298                    (output-form form))
    304299                  (when compile-time-too
    305300                    (eval form))
     
    327322;;;                      (setf form (precompiler:precompile-form form nil))
    328323                  (note-toplevel-form form)
    329                   (setf form (convert-toplevel-form form)))))))))
     324                  (setf form (convert-toplevel-form form nil)))))))))
    330325  (when (consp form)
    331     (dump-form form stream)
    332     (%stream-terpri stream))
     326    (output-form form))
    333327  ;; Make sure the compiled-function loader knows where
    334328  ;; to load the compiled functions. Note that this trickery
     
    361355       :if-exists :supersede)
    362356        (report-error
    363          (jvm:compile-defun nil lambda-expression nil classfile f))))
     357         (jvm:compile-defun nil lambda-expression nil classfile f nil))))
    364358                 (compiled-function (verify-load classfile)))
    365359      (declare (ignore result))
     
    376370interpreted toplevel form, non-NIL if it is 'simple enough'."
    377371  (and (consp form)
    378        (every #'(lambda (arg)
    379                   (or (and (atom arg)
    380                            (not (and (symbolp arg)
    381                                      (symbol-macro-p arg))))
    382                       (and (consp arg)
    383                            (eq 'QUOTE (car arg)))))
     372             (every #'(lambda (arg)
     373                        (or (and (atom arg)
     374                                 (not (and (symbolp arg)
     375                                           (symbol-macro-p arg))))
     376                            (and (consp arg)
     377                                 (eq 'QUOTE (car arg)))))
    384378              (cdr form))))
    385379
     
    406400     :element-type '(unsigned-byte 8)
    407401     :if-exists :supersede)
    408       (report-error (jvm:compile-defun nil expr nil classfile f))))
     402      (report-error (jvm:compile-defun nil expr nil classfile
     403                                             f declare-inline))))
    409404         (compiled-function (verify-load classfile)))
    410405    (declare (ignore result))
     
    448443    (intersection '(:execute eval) situations)))
    449444
     445
     446(defvar *binary-fasls* nil)
     447(defvar *forms-for-output* nil)
     448(defvar *fasl-stream* nil)
     449
     450(defun output-form (form)
     451  (if *binary-fasls*
     452      (push form *forms-for-output*)
     453      (progn
     454        (dump-form form *fasl-stream*)
     455        (%stream-terpri *fasl-stream*))))
     456
     457(defun finalize-fasl-output ()
     458  (when *binary-fasls*
     459    (let ((*package* (find-package :keyword))
     460          (*double-colon-package-separators* T))
     461      (dump-form (convert-toplevel-form (list* 'PROGN
     462                                               (nreverse *forms-for-output*))
     463                                        t)
     464                 *fasl-stream*))
     465    (%stream-terpri *fasl-stream*)))
     466
    450467(defun compile-file (input-file
    451468                     &key
     
    454471                     ((:print *compile-print*) *compile-print*)
    455472                     external-format)
    456   (declare (ignore external-format)) ; FIXME
     473  (declare (ignore external-format))    ; FIXME
    457474  (unless (or (and (probe-file input-file) (not (file-directory-p input-file)))
    458475              (pathname-type input-file))
     
    488505                  (jvm::*functions-defined-in-current-file* '())
    489506                  (*fbound-names* '())
    490                   (*fasl-anonymous-package* (%make-package)))
     507                  (*fasl-anonymous-package* (%make-package))
     508                  (*fasl-stream* out)
     509                  *forms-for-output*)
    491510              (jvm::with-saved-compiler-policy
    492                 (jvm::with-file-compilation
    493                   (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
    494                   (%stream-terpri out)
    495                   (let ((*package* (find-package '#:cl)))
    496                     (write (list 'init-fasl :version *fasl-version*)
    497                            :stream out)
     511                  (jvm::with-file-compilation
     512                      (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
    498513                    (%stream-terpri out)
    499                     (write (list 'setq '*source* *compile-file-truename*)
    500                            :stream out)
    501                     (%stream-terpri out))
    502                   (handler-bind ((style-warning #'(lambda (c)
    503                                                     (setf warnings-p t)
    504                                                     ;; let outer handlers
    505                                                     ;; do their thing
    506                                                     (signal c)
    507                                                     ;; prevent the next
    508                                                     ;; handler from running:
    509                                                     ;; we're a WARNING subclass
    510                                                     (continue)))
    511                                  ((or warning
    512                                       compiler-error) #'(lambda (c)
    513                                                           (declare (ignore c))
    514                                                           (setf warnings-p t
    515                                                                 failure-p t))))
    516                     (loop
    517                        (let* ((*source-position* (file-position in))
    518                               (jvm::*source-line-number* (stream-line-number in))
    519                               (form (read in nil in))
    520                               (*compiler-error-context* form))
    521                          (when (eq form in)
    522                            (return))
    523                          (process-toplevel-form form out nil))))
    524                   (dolist (name *fbound-names*)
    525                     (fmakunbound name)))))))
     514                    (let ((*package* (find-package '#:cl)))
     515                      (write (list 'init-fasl :version *fasl-version*)
     516                             :stream out)
     517                      (%stream-terpri out)
     518                      (write (list 'setq '*source* *compile-file-truename*)
     519                             :stream out)
     520                      (%stream-terpri out))
     521                    (handler-bind ((style-warning #'(lambda (c)
     522                                                      (setf warnings-p t)
     523                                                      ;; let outer handlers
     524                                                      ;; do their thing
     525                                                      (signal c)
     526                                                      ;; prevent the next
     527                                                      ;; handler from running:
     528                                                      ;; we're a WARNING subclass
     529                                                      (continue)))
     530                                   ((or warning
     531                                        compiler-error) #'(lambda (c)
     532                                        (declare (ignore c))
     533                                        (setf warnings-p t
     534                                              failure-p t))))
     535                      (loop
     536                         (let* ((*source-position* (file-position in))
     537                                (jvm::*source-line-number* (stream-line-number in))
     538                                (form (read in nil in))
     539                                (*compiler-error-context* form))
     540                           (when (eq form in)
     541                             (return))
     542                           (process-toplevel-form form out nil))))
     543                    (finalize-fasl-output)
     544                    (dolist (name *fbound-names*)
     545                      (fmakunbound name)))))))
    526546        (rename-file temp-file output-file)
    527547
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12212 r12226  
    19491949      output)))
    19501950
     1951(defvar *declare-inline* nil)
     1952
    19511953(defmacro declare-with-hashtable (declared-item hashtable hashtable-var
    19521954          item-var &body body)
     
    19711973                                      +lisp-symbol-class+))))
    19721974   (t
    1973     (let ((*code* *static-code*)
    1974     (s (sanitize symbol)))
    1975       (setf g (symbol-name (gensym "SYM")))
    1976       (when s
    1977         (setf g (concatenate 'string g "_" s)))
    1978       (declare-field g +lisp-symbol+ +field-access-private+)
    1979       (emit 'ldc (pool-string (symbol-name symbol)))
    1980       (emit 'ldc (pool-string (package-name (symbol-package symbol))))
    1981       (emit-invokestatic +lisp-class+ "internInPackage"
    1982              (list +java-string+ +java-string+) +lisp-symbol+)
    1983       (emit 'putstatic *this-class* g +lisp-symbol+)
    1984       (setf *static-code* *code*)
    1985       (setf (gethash symbol ht) g))))))
     1975          (let ((*code* *static-code*)
     1976                (s (sanitize symbol)))
     1977            (setf g (symbol-name (gensym "SYM")))
     1978            (when s
     1979              (setf g (concatenate 'string g "_" s)))
     1980            (declare-field g +lisp-symbol+ +field-access-private+)
     1981            (emit 'ldc (pool-string (symbol-name symbol)))
     1982            (emit 'ldc (pool-string (package-name (symbol-package symbol))))
     1983            (emit-invokestatic +lisp-class+ "internInPackage"
     1984                               (list +java-string+ +java-string+) +lisp-symbol+)
     1985            (emit 'putstatic *this-class* g +lisp-symbol+)
     1986            (setf *static-code* *code*)
     1987            (setf (gethash symbol ht) g))))))
    19861988
    19871989(defun lookup-or-declare-symbol (symbol)
     
    20012003   symbol *declared-symbols* ht g
    20022004   (let ((*code* *static-code*))
     2005     ;; there's no requirement to declare-inline here:
     2006     ;; keywords are constants, so they can be created any time,
     2007     ;; if early enough
    20032008     (setf g (symbol-name (gensym "KEY")))
    20042009     (declare-field g +lisp-symbol+ +field-access-private+)
     
    20232028         (name class)
    20242029       (lookup-or-declare-symbol symbol)
    2025      (let ((*code* *static-code*))
    2026        (emit 'getstatic class name +lisp-symbol+)
    2027        (emit-invokevirtual +lisp-symbol-class+
    2028                            (if setf
    2029                                "getSymbolSetfFunctionOrDie"
    2030                                "getSymbolFunctionOrDie")
    2031                            nil +lisp-object+)
    2032        (emit 'putstatic *this-class* f +lisp-object+)
    2033        (setf *static-code* *code*)
    2034        (setf (gethash symbol ht) f)))))
     2030     (let (saved-code)
     2031       (let ((*code* (if *declare-inline* *code* *static-code*)))
     2032         (emit 'getstatic class name +lisp-symbol+)
     2033         (emit-invokevirtual +lisp-symbol-class+
     2034                             (if setf
     2035                                 "getSymbolSetfFunctionOrDie"
     2036                                 "getSymbolFunctionOrDie")
     2037                             nil +lisp-object+)
     2038         (emit 'putstatic *this-class* f +lisp-object+)
     2039         (if *declare-inline*
     2040             (setf saved-code *code*)
     2041             (setf *static-code* *code*))
     2042         (setf (gethash symbol ht) f))
     2043       (when *declare-inline*
     2044         (setf *code* saved-code))
     2045       f))))
    20352046
    20362047(defknown declare-setf-function (name) string)
     
    20462057   (let* ((pathname (class-file-pathname (local-function-class-file local-function)))
    20472058    (*code* *static-code*))
     2059     ;; fixme *declare-inline*
    20482060     (declare-field g +lisp-object+ +field-access-default+)
    20492061     (emit 'ldc (pool-string (file-namestring pathname)))
     
    20602072   n *declared-integers* ht g
    20612073   (let ((*code* *static-code*))
     2074     ;; no need to *declare-inline*: constants
    20622075     (setf g (format nil "FIXNUM_~A~D"
    20632076         (if (minusp n) "MINUS_" "")
     
    20812094   (setf g (concatenate 'string "BIGNUM_" (symbol-name (gensym))))
    20822095   (let ((*code* *static-code*))
     2096     ;; no need to *declare-inline*: constants
    20832097     (declare-field g +lisp-integer+ +field-access-private+)
    20842098     (cond ((<= most-negative-java-long n most-positive-java-long)
     
    21052119   s *declared-floats* ht g
    21062120   (let* ((*code* *static-code*))
     2121     ;; no need to *declare-inline*: constants
    21072122     (setf g (concatenate 'string "FLOAT_" (symbol-name (gensym))))
    21082123     (declare-field g +lisp-single-float+ +field-access-private+)
     
    21202135   d *declared-doubles* ht g
    21212136   (let ((*code* *static-code*))
     2137     ;; no need to *declare-inline*: constants
    21222138     (setf g (concatenate 'string "DOUBLE_" (symbol-name (gensym))))
    21232139     (declare-field g +lisp-double-float+ +field-access-private+)
     
    21352151        (n (char-code c))
    21362152        (*code* *static-code*))
     2153     ;; no need to *declare-inline*: constants
    21372154    (declare-field g +lisp-character+ +field-access-private+)
    21382155    (cond ((<= 0 n 255)
     
    21522169(defun declare-object-as-string (obj &optional (obj-ref +lisp-object+)
    21532170                                     obj-class)
    2154   (let* ((g (symbol-name (gensym "OBJSTR")))
    2155          (s (with-output-to-string (stream) (dump-form obj stream)))
    2156          (*code* *static-code*))
    2157     (declare-field g obj-ref +field-access-private+)
    2158     (emit 'ldc (pool-string s))
    2159     (emit-invokestatic +lisp-class+ "readObjectFromString"
    2160                        (list +java-string+) +lisp-object+)
    2161     (when (and obj-class (string/= obj-class +lisp-object+))
    2162       (emit 'checkcast obj-class))
    2163     (emit 'putstatic *this-class* g obj-ref)
    2164     (setf *static-code* *code*)
     2171  (let (saved-code
     2172        (g (symbol-name (gensym "OBJSTR"))))
     2173    (let* ((s (with-output-to-string (stream) (dump-form obj stream)))
     2174           (*code* (if *declare-inline* *code* *static-code*)))
     2175      ;; strings may contain evaluated bits which may depend on
     2176      ;; previous statements
     2177      (declare-field g obj-ref +field-access-private+)
     2178      (emit 'ldc (pool-string s))
     2179      (emit-invokestatic +lisp-class+ "readObjectFromString"
     2180                         (list +java-string+) +lisp-object+)
     2181      (when (and obj-class (string/= obj-class +lisp-object+))
     2182        (emit 'checkcast obj-class))
     2183      (emit 'putstatic *this-class* g obj-ref)
     2184      (if *declare-inline*
     2185          (setf saved-code *code*)
     2186          (setf *static-code* *code*)))
     2187    (when *declare-inline*
     2188      (setf *code* saved-code))
    21652189    g))
    21662190
     
    21692193         (s (with-output-to-string (stream) (dump-form obj stream)))
    21702194         (*code* *static-code*))
     2195    ;; fixme *declare-inline*?
    21712196    (declare-field g +lisp-object+ +field-access-private+)
    21722197    (emit 'ldc (pool-string s))
     
    21872212         (s (with-output-to-string (stream) (dump-form obj stream)))
    21882213         (*code* *static-code*))
     2214    ;; fixme *declare-inline*?
    21892215    (declare-field g +lisp-object+ +field-access-private+)
    21902216    (emit 'ldc (pool-string s))
     
    21982224
    21992225(defun declare-package (obj)
    2200   (let* ((g (symbol-name (gensym "PKG")))
    2201          (*print-level* nil)
    2202          (*print-length* nil)
    2203          (s (format nil "#.(FIND-PACKAGE ~S)" (package-name obj)))
    2204          (*code* *static-code*))
    2205     (declare-field g +lisp-object+ +field-access-private+)
    2206     (emit 'ldc (pool-string s))
    2207     (emit-invokestatic +lisp-class+ "readObjectFromString"
    2208                        (list +java-string+) +lisp-object+)
    2209     (emit 'putstatic *this-class* g +lisp-object+)
    2210     (setf *static-code* *code*)
     2226  (let (saved-code
     2227        (g (symbol-name (gensym "PKG"))))
     2228    (let* ((*print-level* nil)
     2229           (*print-length* nil)
     2230           (s (format nil "#.(FIND-PACKAGE ~S)" (package-name obj)))
     2231           (*code* *static-code*))
     2232      (declare-field g +lisp-object+ +field-access-private+)
     2233      (emit 'ldc (pool-string s))
     2234      (emit-invokestatic +lisp-class+ "readObjectFromString"
     2235                         (list +java-string+) +lisp-object+)
     2236      (emit 'putstatic *this-class* g +lisp-object+)
     2237      (if *declare-inline*
     2238          (setf saved-code *code*)
     2239          (setf *static-code* *code*)))
     2240    (when *declare-inline*
     2241      (setf *code* saved-code))
    22112242    g))
    22122243
     
    22192250The field type of the object is specified by OBJ-REF."
    22202251  (let ((key (symbol-name (gensym "OBJ"))))
     2252    ;; fixme *declare-inline*?
    22212253    (remember key obj)
    22222254    (let* ((g1 (declare-string key))
     
    22342266
    22352267(defun declare-lambda (obj)
    2236   (let* ((g (symbol-name (gensym "LAMBDA")))
    2237          (*print-level* nil)
    2238          (*print-length* nil)
    2239          (s (format nil "~S" obj))
    2240          (*code* *static-code*))
    2241     (declare-field g +lisp-object+ +field-access-private+)
    2242     (emit 'ldc
    2243           (pool-string s))
    2244     (emit-invokestatic +lisp-class+ "readObjectFromString"
    2245                        (list +java-string+) +lisp-object+)
    2246     (emit-invokestatic +lisp-class+ "coerceToFunction"
    2247                        (lisp-object-arg-types 1) +lisp-object+)
    2248     (emit 'putstatic *this-class* g +lisp-object+)
    2249     (setf *static-code* *code*)
     2268  (let (saved-code
     2269        (g (symbol-name (gensym "LAMBDA"))))
     2270    (let* ((*print-level* nil)
     2271           (*print-length* nil)
     2272           (s (format nil "~S" obj))
     2273           (*code* *static-code*))
     2274      (declare-field g +lisp-object+ +field-access-private+)
     2275      (emit 'ldc
     2276            (pool-string s))
     2277      (emit-invokestatic +lisp-class+ "readObjectFromString"
     2278                         (list +java-string+) +lisp-object+)
     2279      (emit-invokestatic +lisp-class+ "coerceToFunction"
     2280                         (lisp-object-arg-types 1) +lisp-object+)
     2281      (emit 'putstatic *this-class* g +lisp-object+)
     2282      (if *declare-inline*
     2283          (setf saved-code *code*)
     2284          (setf *static-code* *code*)))
     2285    (when *declare-inline*
     2286      (setf *code* saved-code))
    22502287    g))
    22512288
     
    22542291   string *declared-strings* ht g
    22552292   (let ((*code* *static-code*))
    2256         (setf g (symbol-name (gensym "STR")))
    2257         (declare-field g +lisp-simple-string+ +field-access-private+)
    2258         (emit 'new +lisp-simple-string-class+)
    2259         (emit 'dup)
    2260         (emit 'ldc (pool-string string))
    2261         (emit-invokespecial-init +lisp-simple-string-class+ (list +java-string+))
    2262         (emit 'putstatic *this-class* g +lisp-simple-string+)
    2263         (setf *static-code* *code*)
    2264         (setf (gethash string ht) g))))
     2293     ;; constant: no need to *declare-inline*
     2294     (setf g (symbol-name (gensym "STR")))
     2295     (declare-field g +lisp-simple-string+ +field-access-private+)
     2296     (emit 'new +lisp-simple-string-class+)
     2297     (emit 'dup)
     2298     (emit 'ldc (pool-string string))
     2299     (emit-invokespecial-init +lisp-simple-string-class+ (list +java-string+))
     2300     (emit 'putstatic *this-class* g +lisp-simple-string+)
     2301     (setf *static-code* *code*)
     2302     (setf (gethash string ht) g))))
    22652303
    22662304(defknown compile-constant (t t t) t)
     
    84498487     (error 'program-error :format-control "Execution of a form compiled with errors.")))
    84508488
    8451 (defun compile-defun (name form environment filespec stream)
     8489(defun compile-defun (name form environment filespec stream *declare-inline*)
    84528490  "Compiles a lambda expression `form'. If `filespec' is NIL,
    84538491a random Java class name is generated, if it is non-NIL, it's used
     
    85738611                (load-compiled-function
    85748612                 (with-open-stream (s (sys::%make-byte-array-output-stream))
    8575                    (compile-defun name expr env nil s)
     8613                   (compile-defun name expr env nil s nil)
    85768614                   (finish-output s)
    85778615                   (sys::%get-output-stream-bytes s))))))
Note: See TracChangeset for help on using the changeset viewer.