Changeset 13810


Ignore:
Timestamp:
01/25/12 21:24:06 (9 years ago)
Author:
ehuelsmann
Message:

Start factoring out p2-compiland as a jvm bytecode generator instead
of a class file generator as a step toward different code generation
strategies.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r13792 r13810  
    40894089        (let ((*current-compiland* compiland))
    40904090          (with-saved-compiler-policy
    4091               (p2-compiland compiland)
     4091              (compile-to-jvm-class compiland)
    40924092            (finish-class (compiland-class-file compiland) f)))))
    40934093    (when stream
     
    69736973
    69746974
    6975 ;; Returns a list with the types of the arguments
    6976 (defun analyze-args (compiland)
    6977   (let* ((args (cadr (compiland-p1-result compiland)))
    6978          (arg-count (length args)))
    6979     (dformat t "analyze-args args = ~S~%" args)
    6980     (aver (not (memq '&AUX args)))
    6981 
    6982     (when (or (memq '&KEY args)
    6983               (memq '&OPTIONAL args)
    6984               (memq '&REST args))
    6985       (setf *using-arg-array* t
    6986             *hairy-arglist-p* t)
    6987       (return-from analyze-args (list +lisp-object-array+)))
    6988 
    6989     (cond ((<= arg-count call-registers-limit)
    6990            (lisp-object-arg-types arg-count))
    6991           (t (setf *using-arg-array* t)
    6992              (setf (compiland-arity compiland) arg-count)
    6993              (list +lisp-object-array+)))))
    6994 
    69956975(defmacro with-open-class-file ((var class-file) &body body)
    69966976  `(with-open-file (,var (abcl-class-file-pathname ,class-file)
     
    70507030        (symbol-name (gensym "LFUN"))))
    70517031
     7032
     7033
    70527034(defknown p2-compiland (t) t)
    7053 (defun p2-compiland (compiland)
     7035(defun p2-compiland (compiland method)
    70547036  (let* ((p1-result (compiland-p1-result compiland))
    70557037         (class-file (compiland-class-file compiland))
     
    70617043          (find compiland *closure-variables* :key #'variable-compiland))
    70627044         (body (cddr p1-result))
    7063          (*using-arg-array* nil)
    7064          (*hairy-arglist-p* nil)
    7065          ;; *hairy-arglist-p* != NIL --> *using-arglist-array* != NIL
    70667045
    70677046         (*child-p* (not (null (compiland-parent compiland))))
    70687047
    7069          (arg-types (analyze-args compiland))
    7070          (method (make-jvm-method "execute" +lisp-object+ arg-types
    7071           :flags '(:final :public)))
    70727048         (*visible-variables* *visible-variables*)
    70737049
    70747050         (*thread* nil)
    70757051         (*initialize-thread-var* nil))
    7076 
    7077     (class-add-method class-file method)
    7078 
    7079     (setf (abcl-class-file-superclass class-file)
    7080           (if (or *hairy-arglist-p*
    7081                   (and *child-p* *closure-variables*))
    7082               +lisp-compiled-closure+
    7083               +lisp-compiled-primitive+))
    7084 
    7085     (let ((constructor
    7086            (make-constructor class-file (compiland-name compiland) args)))
    7087       (setf (abcl-class-file-constructor class-file) constructor)
    7088       (class-add-method class-file constructor))
    7089     (let ((clinit (make-static-initializer class-file)))
    7090       (setf (abcl-class-file-static-initializer class-file) clinit)
    7091       (class-add-method class-file clinit))
    70927052
    70937053    (with-code-to-method (class-file method)
     
    72567216        (setf *code* ())
    72577217        (let ((arity (compiland-arity compiland)))
    7258           (when arity
     7218          (when (and arity
     7219                     *using-arg-array*)
    72597220            (generate-arg-count-check arity)))
    72607221
    72617222        (when *hairy-arglist-p*
    7262           (aload 0) ; this
     7223          (aload 0)                     ; this
    72637224          (aver (not (null (compiland-argument-register compiland))))
    72647225          (aload (compiland-argument-register compiland)) ; arg vector
     
    72837244  t)
    72847245
     7246(defun compile-to-jvm-class (compiland)
     7247  "Returns ?what? ### a jvm class-file object?"
     7248  (let* ((class-file (compiland-class-file compiland))
     7249         (args (cadr (compiland-p1-result compiland)))
     7250         (*hairy-arglist-p* (or (memq '&KEY args)
     7251                                (memq '&OPTIONAL args)
     7252                                (memq '&REST args)))
     7253         (*using-arg-array* (or *hairy-arglist-p*
     7254                                (< call-registers-limit (length args)))))
     7255    (setf (abcl-class-file-superclass class-file)
     7256          (if (or *hairy-arglist-p*
     7257                  (and (not (null (compiland-parent compiland)))
     7258                       *closure-variables*))
     7259              +lisp-compiled-closure+
     7260              +lisp-compiled-primitive+))
     7261    (unless *hairy-arglist-p*
     7262      (setf (compiland-arity compiland)
     7263            (length args)))
     7264
     7265    ;; Static initializer
     7266    (let ((clinit (make-static-initializer class-file)))
     7267      (setf (abcl-class-file-static-initializer class-file) clinit)
     7268      (class-add-method class-file clinit))
     7269
     7270    ;; Constructor
     7271    (let ((constructor
     7272           (make-constructor class-file (compiland-name compiland) args)))
     7273      (setf (abcl-class-file-constructor class-file) constructor)
     7274      (class-add-method class-file constructor))
     7275
     7276    ;; Main method
     7277    (let* ((method-arg-types (if *using-arg-array*
     7278                                 (list +lisp-object-array+)
     7279                                 (lisp-object-arg-types (length args))))
     7280           (method (make-jvm-method "execute" +lisp-object+ method-arg-types
     7281                                    :flags '(:final :public))))
     7282      (class-add-method class-file method)
     7283      (p2-compiland compiland method))))
     7284
    72857285(defun p2-with-inline-code (form target representation)
    72867286  ;;form = (with-inline-code (&optional target-var repr-var) ...body...)
     
    73267326    (with-class-file (compiland-class-file compiland)
    73277327      (with-saved-compiler-policy
    7328         (p2-compiland compiland)
     7328        (compile-to-jvm-class compiland)
    73297329        ;;        (finalize-class-file (compiland-class-file compiland))
    73307330        (finish-class (compiland-class-file compiland) stream)))))
Note: See TracChangeset for help on using the changeset viewer.