Changeset 11521


Ignore:
Timestamp:
01/02/09 15:23:25 (12 years ago)
Author:
vvoutilainen
Message:

Helper macro for derive-compiler type, when checking
for parameter types in derive-type-minus, derive-type-plus,
derive-type-times, derive-type-min and derive-type-ash.

File:
1 edited

Legend:

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

    r11520 r11521  
    61096109  (list 'INTEGER 0 '*))
    61106110
     6111(defmacro when-args-integer (args typenames decls &body body)
     6112  "Checks types of the args provided, if all args are
     6113integer, splits them into high/low bytes and invokes the body.
     6114
     6115args contains the arguments for which the type check is done.
     6116typenames contains names of variables to which the type, low byte
     6117and high byte of the provided arg is stored, to be used in
     6118the body.
     6119decls contains declarations used in the body, similar to let.
     6120body is the body to invoke. "
     6121  (labels ((build-let-when (body args typenames)
     6122     (when args
     6123       (let ((type (third typenames))
     6124       (low (second typenames))
     6125       (high (first typenames)))
     6126         (setf body
     6127         `(let ((,type (derive-compiler-type ,(first args))))
     6128      (when (integer-type-p ,type)
     6129        (let ((,low (integer-type-low ,type))
     6130        (,high (integer-type-high ,type)))
     6131          ,body)))))
     6132       (let ((tmpbody
     6133        (build-let-when body (cdr args) (cdddr typenames))))
     6134         (if tmpbody
     6135       tmpbody
     6136       body)))))
     6137    (build-let-when
     6138     `(let (,@decls) ,@body)
     6139     (reverse args) (reverse typenames))))
     6140
    61116141(defknown derive-type-minus (t) t)
    61126142(defun derive-type-minus (form)
     
    61156145    (case (length args)
    61166146      (1
    6117        (let ((type1 (derive-compiler-type (%car args))))
    6118          (when (integer-type-p type1)
    6119            (let* ((low1 (integer-type-low type1))
    6120                   (high1 (integer-type-high type1))
    6121                   (low (and high1 (- high1)))
    6122                   (high (and low1 (- low1))))
    6123              (setf result-type (%make-integer-type low high))))))
     6147       (when-args-integer
     6148  ((%car args))
     6149  (type1 low1 high1)
     6150  ((low (and high1 (- high1)))
     6151   (high (and low1 (- low1))))
     6152  (setf result-type (%make-integer-type low high))))
    61246153      (2
    6125        (let ((type1 (derive-compiler-type (%car args))))
    6126          (when (integer-type-p type1)
    6127            (let ((type2 (derive-compiler-type (%cadr args))))
    6128              (when (integer-type-p type2)
    6129                ;; Both integer types.
    6130                (let* ((low1 (integer-type-low type1))
    6131                       (high1 (integer-type-high type1))
    6132                       (low2 (integer-type-low type2))
    6133                       (high2 (integer-type-high type2))
    6134                       (low (and low1 high2 (- low1 high2)))
    6135                       (high (and high1 low2 (- high1 low2))))
    6136                  (setf result-type (%make-integer-type low high)))))))))
     6154       (when-args-integer
     6155  ((%car args) (%cadr args))
     6156  (type1 low1 high1 type2 low2 high2)
     6157  ((low (and low1 high2 (- low1 high2)))
     6158   (high (and high1 low2 (- high1 low2))))
     6159  (setf result-type (%make-integer-type low high)))))
    61376160    result-type))
    61386161
     
    61426165        (result-type t))
    61436166    (when (= (length args) 2)
    6144       (let ((type1 (derive-compiler-type (%car args))))
    6145         (when (integer-type-p type1)
    6146           (let ((type2 (derive-compiler-type (%cadr args))))
    6147             (when (integer-type-p type2)
    6148               ;; Both integer types.
    6149               (let* ((low1 (integer-type-low type1))
    6150                      (high1 (integer-type-high type1))
    6151                      (low2 (integer-type-low type2))
    6152                      (high2 (integer-type-high type2))
    6153                      (low (and low1 low2 (+ low1 low2)))
    6154                      (high (and high1 high2 (+ high1 high2))))
    6155                 (setf result-type (%make-integer-type low high))))))))
     6167      (when-args-integer
     6168       ((%car args) (%cadr args))
     6169       (type1 low1 high1 type2 low2 high2)
     6170       ((low (and low1 low2 (+ low1 low2)))
     6171  (high (and high1 high2 (+ high1 high2))))
     6172       (setf result-type (%make-integer-type low high))))
    61566173    result-type))
    61576174
     
    61656182          (let ((n (* arg1 arg2)))
    61666183            (return-from derive-type-times (%make-integer-type n n))))
    6167       (let ((type1 (derive-compiler-type arg1)))
    6168         (when (integer-type-p type1)
    6169           (let ((type2 (derive-compiler-type arg2)))
    6170             (when (integer-type-p type2)
    6171               ;; Both integer types.
    6172               (let ((low1 (integer-type-low type1))
    6173                     (high1 (integer-type-high type1))
    6174                     (low2 (integer-type-low type2))
    6175                     (high2 (integer-type-high type2))
    6176                     (low nil)
    6177                     (high nil))
    6178                 (cond ((not (and low1 low2))
    6179                        ;; Nothing to do.
    6180                        )
    6181                       ((or (minusp low1) (minusp low2))
    6182                        (when (and high1 high2)
    6183                          (let ((max (* (max (abs low1) (abs high1))
    6184                                        (max (abs low2) (abs high2)))))
    6185                            (setf low (- max)
    6186                                  high max))))
    6187                       (t
    6188                        (setf low (* low1 low2))
    6189                        (when (and high1 high2)
    6190                          (setf high (* high1 high2)))))
    6191                 (setf result-type (%make-integer-type low high)))))))))
    6192     result-type))
     6184  (when-args-integer
     6185   (arg1 arg2)
     6186   (type1 low1 high1 type2 low2 high2)
     6187   ((low nil)
     6188    (high nil))
     6189   (cond ((not (and low1 low2))
     6190    ;; Nothing to do.
     6191    )
     6192         ((or (minusp low1) (minusp low2))
     6193    (when (and high1 high2)
     6194      (let ((max (* (max (abs low1) (abs high1))
     6195        (max (abs low2) (abs high2)))))
     6196        (setf low (- max)
     6197        high max))))
     6198         (t
     6199    (setf low (* low1 low2))
     6200    (when (and high1 high2)
     6201      (setf high (* high1 high2)))))
     6202   (setf result-type (%make-integer-type low high)))))
     6203  result-type))
    61936204
    61946205(declaim (ftype (function (t) t) derive-type-max))
     
    62036214        (result-type t))
    62046215    (when (= (length form) 3)
    6205       (let* ((type1 (derive-compiler-type (%car args))))
    6206         (when (integer-type-p type1)
    6207           (let ((type2 (derive-compiler-type (%cadr args))))
    6208             (when (integer-type-p type2)
    6209               ;; Both integer types.
    6210               (let ((low1 (integer-type-low type1))
    6211                     (high1 (integer-type-high type1))
    6212                     (low2 (integer-type-low type2))
    6213                     (high2 (integer-type-high type2))
    6214                     low high)
    6215                 (setf low (if (and low1 low2)
    6216                               (min low1 low2)
    6217                               nil)
    6218                       high (if (and high1 high2)
    6219                                (min high1 high2)
    6220                                nil))
    6221                 (setf result-type (%make-integer-type low high))))))))
     6216      (when-args-integer
     6217       ((%car args) (%cadr args))
     6218       (type1 low1 high1 type2 low2 high2)
     6219       (low high)
     6220       (setf low (if (and low1 low2)
     6221         (min low1 low2)
     6222         nil)
     6223       high (if (and high1 high2)
     6224          (min high1 high2)
     6225          nil))
     6226       (setf result-type (%make-integer-type low high))))
    62226227    result-type))
    62236228
     
    62356240         (arg1 (first args))
    62366241         (arg2 (second args))
    6237          (type1 (derive-compiler-type arg1))
    6238          (type2 (derive-compiler-type arg2))
    62396242         (result-type 'INTEGER))
    6240     (when (and (integer-type-p type1) (integer-type-p type2))
    6241       (let ((low1 (integer-type-low type1))
    6242             (high1 (integer-type-high type1))
    6243             (low2 (integer-type-low type2))
    6244             (high2 (integer-type-high type2)))
    6245         (when (and low1 high1 low2 high2)
    6246           (cond ((fixnum-constant-value type2)
    6247                  (setf arg2 (fixnum-constant-value type2))
    6248                  (cond ((<= -64 arg2 64)
    6249                         (setf result-type
    6250                               (list 'INTEGER (ash low1 arg2) (ash high1 arg2))))
    6251                        ((minusp arg2)
    6252                         (setf result-type
    6253                               (list 'INTEGER
    6254                                     (if (minusp low1) -1 0)
    6255                                     (if (minusp high1) -1 0))))))
    6256                 ((and (>= low1 0) (>= high1 0) (>= low2 0) (>= high2 0))
    6257                  ;; Everything is non-negative.
    6258                  (setf result-type (list 'INTEGER
    6259                                          (ash low1 low2)
    6260                                          (ash high1 high2))))
    6261                 ((and (>= low1 0) (>= high1 0) (<= low2 0) (<= high2 0))
    6262                  ;; Negative (or zero) second argument.
    6263                  (setf result-type (list 'INTEGER
    6264                                          (ash low1 low2)
    6265                                          (ash high1 high2))))))))
     6243    (when-args-integer
     6244     (arg1 arg2)
     6245     (type1 low1 high1 type2 low2 high2)
     6246     ()
     6247     (when (and low1 high1 low2 high2)
     6248       (cond ((fixnum-constant-value type2)
     6249        (setf arg2 (fixnum-constant-value type2))
     6250        (cond ((<= -64 arg2 64)
     6251         (setf result-type
     6252         (list 'INTEGER (ash low1 arg2) (ash high1 arg2))))
     6253        ((minusp arg2)
     6254         (setf result-type
     6255         (list 'INTEGER
     6256         (if (minusp low1) -1 0)
     6257         (if (minusp high1) -1 0))))))
     6258       ((and (>= low1 0) (>= high1 0) (>= low2 0) (>= high2 0))
     6259        ;; Everything is non-negative.
     6260        (setf result-type (list 'INTEGER
     6261              (ash low1 low2)
     6262              (ash high1 high2))))
     6263       ((and (>= low1 0) (>= high1 0) (<= low2 0) (<= high2 0))
     6264        ;; Negative (or zero) second argument.
     6265        (setf result-type (list 'INTEGER
     6266              (ash low1 low2)
     6267              (ash high1 high2)))))))
    62666268    (make-compiler-type result-type)))
    62676269
Note: See TracChangeset for help on using the changeset viewer.