Changeset 13496 for trunk


Ignore:
Timestamp:
08/14/11 17:17:44 (10 years ago)
Author:
ehuelsmann
Message:

Move code around to benefit from performance advantages with backward
referenced functions.

File:
1 edited

Legend:

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

    r13495 r13496  
    106106    (terpri)))
    107107
     108(defun output-form (form)
     109  (if *binary-fasls*
     110      (push form *forms-for-output*)
     111      (progn
     112        (dump-form form *fasl-stream*)
     113        (%stream-terpri *fasl-stream*))))
     114
     115(defun finalize-fasl-output ()
     116  (when *binary-fasls*
     117    (let ((*package* (find-package :keyword))
     118          (*double-colon-package-separators* T))
     119      (dump-form (convert-toplevel-form (list* 'PROGN
     120                                               (nreverse *forms-for-output*))
     121                                        t)
     122                 *fasl-stream*))
     123    (%stream-terpri *fasl-stream*)))
     124
     125
     126
     127
     128(declaim (ftype (function (t stream t) t) process-progn))
     129(defun process-progn (forms stream compile-time-too)
     130  (dolist (form forms)
     131    (process-toplevel-form form stream compile-time-too))
     132  nil)
     133
    108134
    109135(declaim (ftype (function (t t t) t) process-toplevel-form))
     
    118144
    119145
    120 
     146(defun process-toplevel-macrolet (form stream compile-time-too)
     147  (let ((*compile-file-environment*
     148         (make-environment *compile-file-environment*)))
     149    (dolist (definition (cadr form))
     150      (environment-add-macro-definition *compile-file-environment*
     151                                        (car definition)
     152                                        (make-macro (car definition)
     153                                                    (make-expander-for-macrolet definition))))
     154    (dolist (body-form (cddr form))
     155      (process-toplevel-form body-form stream compile-time-too)))
     156  nil)
    121157
    122158(declaim (ftype (function (t t t) t) process-toplevel-defconstant))
     
    156192(defun process-toplevel-mop.ensure-method (form stream compile-time-too)
    157193  (declare (ignore stream))
    158   (let ((form (convert-ensure-method form)))
     194  (flet ((convert-ensure-method (form key)
     195           (let* ((tail (cddr form))
     196                  (function-form (getf tail key)))
     197             (when (and function-form (consp function-form)
     198               (eq (%car function-form) 'FUNCTION))
     199               (let ((lambda-expression (cadr function-form)))
     200                 (jvm::with-saved-compiler-policy
     201                     (let* ((saved-class-number *class-number*)
     202                            (classfile (next-classfile-name))
     203                            (result
     204                             (with-open-file
     205                                 (f classfile
     206                                    :direction :output
     207                                    :element-type '(unsigned-byte 8)
     208                                    :if-exists :supersede)
     209                               (report-error
     210                                (jvm:compile-defun nil lambda-expression
     211                                                   *compile-file-environment*
     212                                                   classfile f nil))))
     213                            (compiled-function (verify-load classfile)))
     214                       (declare (ignore result))
     215                       (cond
     216                         (compiled-function
     217                          (setf (getf tail key)
     218                                `(sys::get-fasl-function *fasl-loader*
     219                                                         ,saved-class-number)))
     220                         (t
     221                          ;; FIXME This should be a warning or error of some sort...
     222                          (format *error-output* "; Unable to compile method~%"))))))))))
     223
     224
     225    (convert-ensure-method form :function)
     226    (convert-ensure-method form :fast-function))
     227  (let ((form (precompiler:precompile-form form nil
     228                                           *compile-file-environment*)))
    159229    (when compile-time-too
    160230      (eval form))
     
    208278(declaim (ftype (function (t t t) t) process-toplevel-eval-when))
    209279(defun process-toplevel-eval-when (form stream compile-time-too)
    210   (multiple-value-bind (ct lt e)
    211       (parse-eval-when-situations (cadr form))
    212     (let ((new-compile-time-too (or ct (and compile-time-too e)))
    213           (body (cddr form)))
    214       (if lt
    215           (process-progn body stream new-compile-time-too)
    216           (when new-compile-time-too
    217             (eval `(progn ,@body))))))
     280  (flet ((parse-eval-when-situations (situations)
     281           "Parse an EVAL-WHEN situations list, returning three flags,
     282            (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
     283            the types of situations present in the list."
     284            ; Adapted from SBCL.
     285           (when (or (not (listp situations))
     286                     (set-difference situations
     287                                     '(:compile-toplevel
     288                                       compile
     289                                       :load-toplevel
     290                                       load
     291                                       :execute
     292                                       eval)))
     293             (error "Bad EVAL-WHEN situation list: ~S." situations))
     294           (values (intersection '(:compile-toplevel compile) situations)
     295                   (intersection '(:load-toplevel load) situations)
     296                   (intersection '(:execute eval) situations))))
     297    (multiple-value-bind (ct lt e)
     298        (parse-eval-when-situations (cadr form))
     299      (let ((new-compile-time-too (or ct (and compile-time-too e)))
     300            (body (cddr form)))
     301        (if lt
     302            (process-progn body stream new-compile-time-too)
     303            (when new-compile-time-too
     304              (eval `(progn ,@body)))))))
    218305  nil)
    219306
     
    433520      (eval form))))
    434521
    435 (declaim (ftype (function (t) t) convert-ensure-method))
    436 (defun convert-ensure-method (form)
    437   (c-e-m-1 form :function)
    438   (c-e-m-1 form :fast-function)
    439   (precompiler:precompile-form form nil *compile-file-environment*))
    440 
    441 (declaim (ftype (function (t t) t) c-e-m-1))
    442 (defun c-e-m-1 (form key)
    443   (let* ((tail (cddr form))
    444          (function-form (getf tail key)))
    445     (when (and function-form (consp function-form)
    446                (eq (%car function-form) 'FUNCTION))
    447       (let ((lambda-expression (cadr function-form)))
    448         (jvm::with-saved-compiler-policy
    449           (let* ((saved-class-number *class-number*)
    450      (classfile (next-classfile-name))
    451                  (result
    452       (with-open-file
    453           (f classfile
    454        :direction :output
    455        :element-type '(unsigned-byte 8)
    456        :if-exists :supersede)
    457         (report-error
    458          (jvm:compile-defun nil lambda-expression
    459                                         *compile-file-environment*
    460                                         classfile f nil))))
    461                  (compiled-function (verify-load classfile)))
    462       (declare (ignore result))
    463             (cond (compiled-function
    464                    (setf (getf tail key)
    465        `(sys::get-fasl-function *fasl-loader* ,saved-class-number)))
    466                   (t
    467                    ;; FIXME This should be a warning or error of some sort...
    468                    (format *error-output* "; Unable to compile method~%")))))))))
    469522
    470523(declaim (ftype (function (t) t) simple-toplevel-form-p))
     
    514567
    515568
    516 (defun process-toplevel-macrolet (form stream compile-time-too)
    517   (let ((*compile-file-environment* (make-environment *compile-file-environment*)))
    518     (dolist (definition (cadr form))
    519       (environment-add-macro-definition *compile-file-environment*
    520                                         (car definition)
    521                                         (make-macro (car definition)
    522                                                     (make-expander-for-macrolet definition))))
    523     (dolist (body-form (cddr form))
    524       (process-toplevel-form body-form stream compile-time-too)))
    525   nil) ;; nothing to be sent to output
    526 
    527 (declaim (ftype (function (t stream t) t) process-progn))
    528 (defun process-progn (forms stream compile-time-too)
    529   (dolist (form forms)
    530     (process-toplevel-form form stream compile-time-too))
    531   nil)
    532 
    533 ;;; Adapted from SBCL.
    534 ;;; Parse an EVAL-WHEN situations list, returning three flags,
    535 ;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
    536 ;;; the types of situations present in the list.
    537 (defun parse-eval-when-situations (situations)
    538   (when (or (not (listp situations))
    539       (set-difference situations
    540           '(:compile-toplevel
    541             compile
    542             :load-toplevel
    543             load
    544             :execute
    545             eval)))
    546     (error "Bad EVAL-WHEN situation list: ~S." situations))
    547   (values (intersection '(:compile-toplevel compile) situations)
    548     (intersection '(:load-toplevel load) situations)
    549     (intersection '(:execute eval) situations)))
    550 
    551 
    552569(defvar *binary-fasls* nil)
    553570(defvar *forms-for-output* nil)
    554571(defvar *fasl-stream* nil)
    555 
    556 (defun output-form (form)
    557   (if *binary-fasls*
    558       (push form *forms-for-output*)
    559       (progn
    560         (dump-form form *fasl-stream*)
    561         (%stream-terpri *fasl-stream*))))
    562 
    563 (defun finalize-fasl-output ()
    564   (when *binary-fasls*
    565     (let ((*package* (find-package :keyword))
    566           (*double-colon-package-separators* T))
    567       (dump-form (convert-toplevel-form (list* 'PROGN
    568                                                (nreverse *forms-for-output*))
    569                                         t)
    570                  *fasl-stream*))
    571     (%stream-terpri *fasl-stream*)))
    572572
    573573(defun compile-file (input-file
Note: See TracChangeset for help on using the changeset viewer.