Changeset 11829


Ignore:
Timestamp:
05/04/09 19:43:30 (13 years ago)
Author:
ehuelsmann
Message:

Simplify p1-compiland and p2-compiland.
Create a new 'free-specials' field in the compiland
structure to share work done in p1 with p2.

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

Legend:

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

    r11828 r11829  
    10211021
    10221022    (let* ((lambda-list (cadr form))
    1023            (body (cddr form)))
    1024 
    1025       (let* ((closure (make-closure `(lambda ,lambda-list nil) nil))
    1026              (syms (sys::varlist closure))
    1027              (vars nil))
    1028         (dolist (sym syms)
    1029           (let ((var (make-variable :name sym
    1030                                     :special-p (special-variable-p sym))))
    1031             (push var vars)
    1032             (push var *all-variables*)))
    1033         (setf (compiland-arg-vars compiland) (nreverse vars))
    1034         (let ((*visible-variables* *visible-variables*))
    1035           (dolist (var (compiland-arg-vars compiland))
    1036             (push var *visible-variables*))
    1037           (let ((free-specials (process-declarations-for-vars body *visible-variables*)))
    1038             (dolist (var free-specials)
    1039               (push var *visible-variables*)))
    1040           (setf (compiland-p1-result compiland)
    1041                 (list* 'LAMBDA lambda-list (p1-body body))))))))
     1023           (body (cddr form))
     1024           (*visible-variables* *visible-variables*)
     1025           (closure (make-closure `(lambda ,lambda-list nil) nil))
     1026           (syms (sys::varlist closure))
     1027           (vars nil))
     1028      (dolist (sym syms)
     1029        (let ((var (make-variable :name sym
     1030                                  :special-p (special-variable-p sym))))
     1031          (push var vars)
     1032          (push var *all-variables*)
     1033          (push var *visible-variables*)))
     1034      (setf (compiland-arg-vars compiland) (nreverse vars))
     1035      (let ((free-specials (process-declarations-for-vars body vars)))
     1036        (setf (compiland-free-specials compiland) free-specials)
     1037        (dolist (var free-specials)
     1038          (push var *visible-variables*)))
     1039      (setf (compiland-p1-result compiland)
     1040            (list* 'LAMBDA lambda-list (p1-body body))))))
    10421041
    10431042(provide "COMPILER-PASS1")
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r11828 r11829  
    81618161         (*visible-variables* *visible-variables*)
    81628162
    8163          (parameters ())
    8164 
    81658163         (*thread* nil)
    81668164         (*initialize-thread-var* nil)
     
    81728170    (dolist (var (compiland-arg-vars compiland))
    81738171      (push var *visible-variables*))
     8172    (dolist (var (compiland-free-specials compiland))
     8173      (push var *visible-variables*))
    81748174
    81758175    (setf (method-name-index execute-method)
     
    81788178          (pool-name (method-descriptor execute-method)))
    81798179    (cond (*hairy-arglist-p*
    8180            (let* ((closure (make-closure p1-result nil))
    8181                   (parameter-names (sys::varlist closure))
    8182                   (index 0))
    8183              (dolist (name parameter-names)
    8184                (let ((variable (find-visible-variable name)))
    8185                  (unless variable
    8186                    (format t "1: unable to find variable ~S~%" name)
    8187                    (aver nil))
    8188                  (aver (null (variable-register variable)))
    8189                  (aver (null (variable-index variable)))
    8190                  (setf (variable-index variable) index)
    8191                  (push variable parameters)
    8192                  (incf index)))))
     8180           (let ((index 0))
     8181             (dolist (variable (compiland-arg-vars compiland))
     8182               (aver (null (variable-register variable)))
     8183               (aver (null (variable-index variable)))
     8184               (setf (variable-index variable) index)
     8185               (incf index))))
    81938186          (t
    81948187           (let ((register (if (and *closure-variables* *child-p*)
     
    81968189                               1))
    81978190                 (index 0))
    8198              (dolist (arg args)
    8199                (let ((variable (find-visible-variable arg)))
    8200                  (when (null variable)
    8201                    (format t "2: unable to find variable ~S~%" arg)
    8202                    (aver nil))
    8203                  (aver (null (variable-register variable)))
    8204                  (setf (variable-register variable) (if *using-arg-array* nil register))
    8205                  (aver (null (variable-index variable)))
    8206                  (if *using-arg-array*
    8207                      (setf (variable-index variable) index))
    8208                  (push variable parameters)
    8209                  (incf register)
    8210                  (incf index))))))
    8211 
    8212     (let ((specials (process-special-declarations body)))
    8213       (dolist (name specials)
    8214         (dformat t "recognizing ~S as special~%" name)
    8215         (let ((variable (find-visible-variable name)))
    8216           (cond ((null variable)
    8217                  (setf variable (make-variable :name name
    8218                                                :special-p t))
    8219                  (push variable *visible-variables*))
    8220                 (t
    8221                  (setf (variable-special-p variable) t))))))
     8191             (dolist (variable (compiland-arg-vars compiland))
     8192               (aver (null (variable-register variable)))
     8193               (setf (variable-register variable)
     8194                     (if *using-arg-array* nil register))
     8195               (aver (null (variable-index variable)))
     8196               (if *using-arg-array*
     8197                   (setf (variable-index variable) index))
     8198               (incf register)
     8199               (incf index)))))
    82228200
    82238201    (p2-compiland-process-type-declarations body)
     
    82338211           (unless (or *closure-variables* *child-p*)
    82348212             ;; Reserve a register for each parameter.
    8235              (dolist (variable (reverse parameters))
     8213             (dolist (variable (compiland-arg-vars compiland))
    82368214               (aver (null (variable-register variable)))
    82378215               (aver (null (variable-reserved-register variable)))
     
    82408218          (t
    82418219           ;; Otherwise, one register for each argument.
    8242            (dolist (arg args)
    8243              (declare (ignore arg))
     8220           (dolist (variable (compiland-arg-vars compiland))
     8221             (declare (ignore variable))
    82448222             (allocate-register))))
    82458223    (when (and *closure-variables* (not *child-p*))
     
    82568234      (cond (*child-p*
    82578235             (aver (eql (compiland-closure-register compiland) 1))
    8258              (when (some #'variable-closure-index parameters)
     8236             (when (some #'variable-closure-index
     8237                         (compiland-arg-vars compiland))
    82598238               (aload (compiland-closure-register compiland))))
    82608239            (t
     
    82628241             (dformat t "p2-compiland ~S anewarray 1~%" (compiland-name compiland))
    82638242             (emit 'anewarray "org/armedbear/lisp/LispObject")))
    8264       (dolist (variable parameters)
     8243      (dolist (variable (compiland-arg-vars compiland))
    82658244        (dformat t "considering ~S ...~%" (variable-name variable))
    82668245        (when (variable-closure-index variable)
     
    82888267      (aver (not (null (compiland-closure-register compiland))))
    82898268      (cond (*child-p*
    8290              (when (some #'variable-closure-index parameters)
     8269             (when (some #'variable-closure-index
     8270                         (compiland-arg-vars compiland))
    82918271               (emit 'pop)))
    82928272            (t
     
    82988278    (when *using-arg-array*
    82998279      (unless (or *closure-variables* *child-p*)
    8300         (dolist (variable (reverse parameters))
     8280        (dolist (variable (compiland-arg-vars compiland))
    83018281          (when (variable-reserved-register variable)
    83028282            (aver (not (variable-special-p variable)))
     
    83088288            (setf (variable-index variable) nil)))))
    83098289
    8310     (generate-type-checks-for-variables (reverse parameters))
     8290    (generate-type-checks-for-variables (compiland-arg-vars compiland))
    83118291
    83128292    ;; Unbox variables.
    8313     (dolist (variable (reverse parameters))
     8293    (dolist (variable (compiland-arg-vars compiland))
    83148294      (p2-compiland-unbox-variable variable))
    83158295
    83168296    ;; Establish dynamic bindings for any variables declared special.
    8317     (when (some #'variable-special-p parameters)
     8297    (when (some #'variable-special-p (compiland-arg-vars compiland))
    83188298      ;; Save the dynamic environment
    83198299      (setf (compiland-environment-register compiland)
     
    83238303            +lisp-special-binding+)
    83248304      (astore (compiland-environment-register compiland))
    8325       (label label-START))
    8326     (dolist (variable parameters)
    8327       (when (variable-special-p variable)
    8328         (cond ((variable-register variable)
    8329                (emit-push-current-thread)
    8330                (emit-push-variable-name variable)
    8331                (aload (variable-register variable))
    8332                (emit-invokevirtual +lisp-thread-class+ "bindSpecial"
    8333                                    (list +lisp-symbol+ +lisp-object+) nil)
    8334                (setf (variable-register variable) nil))
    8335               ((variable-index variable)
    8336                (emit-push-current-thread)
    8337                (emit-push-variable-name variable)
    8338                (aload (compiland-argument-register compiland))
    8339                (emit-push-constant-int (variable-index variable))
    8340                (emit 'aaload)
    8341                (emit-invokevirtual +lisp-thread-class+ "bindSpecial"
    8342                                    (list +lisp-symbol+ +lisp-object+) nil)
    8343                (setf (variable-index variable) nil)))))
     8305      (label label-START)
     8306      (dolist (variable (compiland-arg-vars compiland))
     8307        (when (variable-special-p variable)
     8308          (cond ((variable-register variable)
     8309                 (emit-push-current-thread)
     8310                 (emit-push-variable-name variable)
     8311                 (aload (variable-register variable))
     8312                 (emit-invokevirtual +lisp-thread-class+ "bindSpecial"
     8313                                     (list +lisp-symbol+ +lisp-object+) nil)
     8314                 (setf (variable-register variable) nil))
     8315                ((variable-index variable)
     8316                 (emit-push-current-thread)
     8317                 (emit-push-variable-name variable)
     8318                 (aload (compiland-argument-register compiland))
     8319                 (emit-push-constant-int (variable-index variable))
     8320                 (emit 'aaload)
     8321                 (emit-invokevirtual +lisp-thread-class+ "bindSpecial"
     8322                                     (list +lisp-symbol+ +lisp-object+) nil)
     8323                 (setf (variable-index variable) nil))))))
    83448324
    83458325    (compile-progn-body body 'stack)
  • trunk/abcl/src/org/armedbear/lisp/jvm.lisp

    r11828 r11829  
    157157  lambda-expression
    158158  arg-vars
     159  free-specials
    159160  arity ; NIL if the number of args can vary.
    160161  p1-result
Note: See TracChangeset for help on using the changeset viewer.