Changeset 11619


Ignore:
Timestamp:
02/03/09 08:23:31 (12 years ago)
Author:
ehuelsmann
Message:

Reduce code duplication:

move variable representation deduction to DERIVE-VARIABLE-REPRESENTATION.

Also: introduce EMIT-MOVE-TO-VARIABLE to move values off the stack to a variable slot,

another source for code duplication.

File:
1 edited

Legend:

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

    r11617 r11619  
    523523                (compiler-subtypep the-type (make-compiler-type type)))
    524524        (return-from type-representation (caar types))))))
     525
     526(defun representation-size (representation)
     527  (ecase representation
     528    ((NIL :int :boolean :float :char) 1)
     529    ((:long :double) 2)))
    525530
    526531;;                     source type /
     
    41874192        (setf (block-vars block) (remove variable (block-vars block)))))))
    41884193
     4194(defun derive-variable-representation (variable block
     4195                                       &key (type nil type-supplied-p))
     4196  (when (not (null (variable-representation variable)))
     4197    ;; representation already derived
     4198    (return-from derive-variable-representation))
     4199  (when type-supplied-p
     4200    (setf (variable-declared-type variable) type))
     4201  (let ((type (variable-declared-type variable)))
     4202    (when (and (eq (variable-declared-type variable) :none)
     4203               (eql (variable-writes variable) 0))
     4204      (setf type (variable-derived-type variable)))
     4205    (cond ((neq type :none)
     4206           (setf (variable-representation variable)
     4207                 (type-representation type))
     4208           (unless (memq (variable-representation variable) '(:int :long))
     4209             ;; We don't support unboxed variables other than INT and LONG (yet)
     4210             (setf (variable-representation variable) NIL)))
     4211          ((zerop (variable-writes variable))
     4212           (when (eq :none (variable-derived-type variable))
     4213             (setf (variable-derived-type variable)
     4214                   (derive-compiler-type (variable-initform variable))))
     4215           (let ((derived-type (variable-derived-type variable)))
     4216             (setf (variable-derived-type variable) derived-type)
     4217             (setf (variable-representation variable)
     4218                   (type-representation derived-type))
     4219             (unless (memq (variable-representation variable) '(:int :long))
     4220               ;; We don't support unboxed variables other than INT and LONG (yet)
     4221               (setf (variable-representation variable) NIL))))
     4222          ((and block
     4223                (get (variable-name variable) 'sys::dotimes-index-variable-p))
     4224           ;; DOTIMES index variable.
     4225           (let* ((name (get (variable-name variable)
     4226                             'sys::dotimes-limit-variable-name))
     4227                  (limit-variable (and name
     4228                                       (or (find-variable name
     4229                                                          (block-vars block))
     4230                                           (find-visible-variable name)))))
     4231             (derive-variable-representation limit-variable block)
     4232             (setf (variable-representation variable)
     4233                   (variable-representation limit-variable)))))))
     4234
     4235(defun allocate-variable-register (variable)
     4236  (setf (variable-register variable)
     4237        (if (= 2 (representation-size (variable-representation variable)))
     4238            (allocate-register-pair)
     4239            (allocate-register))))
     4240
     4241(defun emit-move-to-variable (variable)
     4242  (flet ((emit-array-store (representation)
     4243           (emit (or (case representation
     4244                       ((:int :boolean :char)
     4245                                'iastore)
     4246                       (:long   'lastore)
     4247                       (:float  'fastore)
     4248                       (:double 'dastore))
     4249                   'aastore))))
     4250    (cond ((variable-register variable)
     4251           (emit (or (case (variable-representation variable)
     4252                       ((:int :boolean :char)
     4253                                'istore)
     4254                       (:long   'lstore)
     4255                       (:float  'fstore)
     4256                       (:double 'dstore))
     4257                     'astore)
     4258                 (variable-register variable)))
     4259          ((variable-index variable)
     4260           (aload (compiland-argument-register *current-compiland*))
     4261           (emit-push-constant-int (variable-index variable))
     4262           (emit-array-store (variable-representation variable)))
     4263          ((variable-closure-index variable)
     4264           (aload (compiland-closure-register *current-compiland*))
     4265           (emit-push-constant-int (variable-closure-index variable))
     4266           (emit-array-store (variable-representation variable)))
     4267          (t ;;###FIXME: We might want to address the "temp-register" case too.
     4268           (assert nil)))))
     4269
     4270
    41894271(defknown p2-let-bindings (t) t)
    41904272(defun p2-let-bindings (block)
     
    42134295               (cond (initform
    42144296                      (when (eq (variable-register variable) t)
    4215                         (let ((declared-type (variable-declared-type variable)))
    4216                           (cond ((neq declared-type :none)
    4217                                  (cond ((fixnum-type-p declared-type)
    4218                                         (setf (variable-representation variable) :int))
    4219                                        ((java-long-type-p declared-type)
    4220                                         (setf (variable-representation variable) :long))))
    4221                                 ((zerop (variable-writes variable))
    4222                                  (let ((derived-type (derive-compiler-type initform)))
    4223                                    (setf (variable-derived-type variable) derived-type)
    4224                                    (cond ((fixnum-type-p derived-type)
    4225                                           (setf (variable-representation variable) :int))
    4226                                          ((java-long-type-p derived-type)
    4227                                           (setf (variable-representation variable) :long)))))
    4228                                 ((get (variable-name variable) 'sys::dotimes-index-variable-p)
    4229                                  ;; DOTIMES index variable.
    4230                                  (let* ((name (get (variable-name variable) 'sys::dotimes-limit-variable-name))
    4231                                         (limit-variable (and name
    4232                                                              (or (find-variable name (block-vars block))
    4233                                                                  (find-visible-variable name)))))
    4234                                    (when limit-variable
    4235                                      (let ((type (variable-derived-type limit-variable)))
    4236                                        (when (eq type :none)
    4237                                          (setf type (variable-declared-type limit-variable)))
    4238                                        (cond ((fixnum-type-p type)
    4239                                               (setf (variable-representation variable) :int
    4240 ;;                                                     (variable-derived-type variable) 'FIXNUM
    4241                                                     (variable-derived-type variable) type
    4242                                                     ))
    4243                                              ((java-long-type-p type)
    4244                                               (setf (variable-representation variable) :long
    4245 ;;                                                     (variable-derived-type variable) 'JAVA-LONG
    4246                                                     (variable-derived-type variable) type
    4247                                                     ))))))))))
    4248                       (compile-form initform 'stack (variable-representation variable))
     4297                        (derive-variable-representation variable block))
     4298                      (compile-form initform 'stack
     4299                                    (variable-representation variable))
    42494300                      (unless must-clear-values
    42504301                        (unless (single-valued-p initform)
     
    42554306               (when (eq (variable-register variable) t)
    42564307                 ;; Now allocate the register.
    4257                  (setf (variable-register variable)
    4258                        (case (variable-representation variable)
    4259                          (:long
    4260                           ;; We need two registers for a long.
    4261                           (allocate-register-pair))
    4262                          (t
    4263                           (allocate-register)))))
     4308                 (allocate-variable-register variable))
    42644309               (cond ((variable-special-p variable)
    42654310                      (emit-move-from-stack (setf (variable-temp-register variable) (allocate-register))))
    4266                      ((eq (variable-representation variable) :int)
    4267                       (emit 'istore (variable-register variable)))
    4268                      ((eq (variable-representation variable) :long)
    4269                       (emit 'lstore (variable-register variable)))
     4311                     ((variable-representation variable)
     4312                      (emit-move-to-variable variable))
    42704313                     (t
    42714314                      (compile-binding variable)))))))
     
    43284371                        (emit-push-nil))))
    43294372                (t
    4330                   (cond (unused-p
    4331                          (compile-form initform nil nil) ; for effect
    4332                          (update-must-clear-values)
    4333                          (setf boundp t))
    4334                         ((and (null (variable-closure-index variable))
    4335                               (not (variable-special-p variable)))
    4336                          (let ((declared-type (variable-declared-type variable)))
    4337                            (cond ((and (neq declared-type :none)
    4338                                        (fixnum-type-p declared-type))
    4339                                   (setf (variable-representation variable) :int)
    4340                                   (compile-form initform 'stack :int)
    4341                                   (update-must-clear-values)
    4342                                   (setf (variable-register variable) (allocate-register))
    4343                                   (emit 'istore (variable-register variable))
    4344                                   (setf boundp t))
    4345                                  ((and (neq declared-type :none)
    4346                                        (java-long-type-p declared-type))
    4347                                   (setf (variable-representation variable) :long)
    4348                                   (compile-form initform 'stack :long)
    4349                                   (update-must-clear-values)
    4350                                   (setf (variable-register variable)
    4351                                         ;; We need two registers for a long.
    4352                                         (allocate-register-pair))
    4353                                   (emit 'lstore (variable-register variable))
    4354                                   (setf boundp t))
    4355                                  ((and (neq declared-type :none)
    4356                                        (eq declared-type 'BOOLEAN))
    4357                                   (setf (variable-representation variable) :boolean)
    4358                                   (compile-form initform 'stack :boolean)
    4359                                   (update-must-clear-values)
    4360                                   (setf (variable-register variable) (allocate-register))
    4361                                   (emit 'istore (variable-register variable))
    4362                                   (setf boundp t))
    4363                                  ((eql (variable-writes variable) 0)
    4364                                   (let ((type (derive-compiler-type initform)))
    4365                                     (setf (variable-derived-type variable) type)
    4366                                     (cond ((fixnum-type-p type)
    4367                                            (setf (variable-representation variable) :int)
    4368                                            (setf (variable-register variable) (allocate-register))
    4369                                            (compile-form initform 'stack :int)
    4370                                            (update-must-clear-values)
    4371                                            (emit 'istore (variable-register variable))
    4372                                            (setf boundp t))
    4373                                           ((java-long-type-p type)
    4374                                            (setf (variable-representation variable) :long)
    4375                                            (setf (variable-register variable)
    4376                                                  ;; We need two registers for a long.
    4377                                                  (allocate-register-pair))
    4378                                            (compile-form initform 'stack :long)
    4379                                            (update-must-clear-values)
    4380                                            (emit 'lstore (variable-register variable))
    4381                                            (setf boundp t))
    4382                                           ((eq type 'CHARACTER)
    4383                                            (setf (variable-representation variable) :char)
    4384                                            (setf (variable-register variable) (allocate-register))
    4385                                            (compile-form initform 'stack :char)
    4386                                            (update-must-clear-values)
    4387                                            (emit 'istore (variable-register variable))
    4388                                            (setf boundp t))
    4389                                           (t
    4390                                            (compile-form initform 'stack nil)
    4391                                            (update-must-clear-values)))))
    4392                                  (t
    4393                                   (compile-form initform 'stack nil)
    4394                                   (update-must-clear-values)))))
    4395                         (t
    4396                          (compile-form initform 'stack nil)
    4397                          (update-must-clear-values))))))
     4373                 (cond (unused-p
     4374                        (compile-form initform nil nil) ; for effect
     4375                        (update-must-clear-values)
     4376                        (setf boundp t))
     4377                       ((and (null (variable-closure-index variable))
     4378                             (not (variable-special-p variable)))
     4379                        (when (and (eq (variable-declared-type variable) :none)
     4380                                   (eql (variable-writes variable) 0))
     4381                          (setf (variable-derived-type variable)
     4382                                (derive-compiler-type initform)))
     4383                        (derive-variable-representation variable block)
     4384                        (allocate-variable-register variable)
     4385                        (compile-form initform 'stack
     4386                                      (variable-representation variable))
     4387                        (update-must-clear-values)
     4388                        (emit-move-to-variable variable)
     4389                        (setf boundp t))
     4390                       (t
     4391                        (compile-form initform 'stack nil)
     4392                        (update-must-clear-values))))))
    43984393        (unless (or boundp (variable-special-p variable))
    4399           (unless (or (variable-closure-index variable) (variable-register variable))
     4394          (unless (or (variable-closure-index variable)
     4395                      (variable-register variable))
    44004396            (setf (variable-register variable) (allocate-register))))
    44014397        (push variable *visible-variables*)
Note: See TracChangeset for help on using the changeset viewer.