Changeset 11604


Ignore:
Timestamp:
01/30/09 06:16:49 (12 years ago)
Author:
ehuelsmann
Message:

Smarter type derivation: start *using* the float and double storage types
(in P2-PLUS and P2-MINUS, others to follow).

File:
1 edited

Legend:

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

    r11603 r11604  
    712712  (unless (or (zerop *safety*)
    713713              (variable-special-p variable)
     714              ;###
    714715              (eq (variable-representation variable) :int))
    715716    (let ((declared-type (variable-declared-type variable)))
     
    23242325        (setf *static-code* *code*)
    23252326        (setf (gethash string ht) g))))
    2326      
     2327
    23272328(defknown compile-constant (t t t) t)
    23282329(defun compile-constant (form target representation)
     
    62616262     (reverse args) (reverse typenames))))
    62626263
     6264
     6265(defmacro define-int-bounds-derivation (name (low1 high1 low2 high2)
     6266                                        &body body)
     6267  "Associates an integer-bounds calculation function with a numeric
     6268operator `name', assuming 2 integer arguments."
     6269  `(setf (get ',name 'int-bounds)
     6270         #'(lambda (,low1 ,high1 ,low2 ,high2)
     6271             (declare (ignorable ,low1 ,high1 ,low2 ,high2))
     6272             ,@body)))
     6273
     6274
     6275(defun derive-integer-type (op type1 type2)
     6276  "Derives the composed integer type of operation `op' given integer
     6277types `type1' and `type2'."
     6278  (let ((low1 (integer-type-low type1))
     6279        (high1 (integer-type-high type1))
     6280        (low2 (integer-type-low type2))
     6281        (high2 (integer-type-high type2))
     6282        (op-fn (get op 'int-bounds)))
     6283    (assert op-fn)
     6284    (multiple-value-bind
     6285          (low high non-int-p)
     6286        (funcall op-fn low1 high1 low2 high2)
     6287      (if non-int-p
     6288          non-int-p
     6289          (%make-integer-type low high)))))
     6290
     6291(defvar numeric-op-type-derivation
     6292  `(((+ - * /)
     6293     (integer integer ,#'derive-integer-type)
     6294     (integer single-float single-float)
     6295     (integer double-float double-float)
     6296     (single-float integer single-float)
     6297     (single-float double-float double-float)
     6298     (double-float integer double-float)
     6299     (double-float single-float double-float))
     6300    ((min max)
     6301     (integer integer ,#'derive-integer-type)
     6302     (integer single-float single-float)
     6303     (integer double-float double-float)
     6304     (single-float double-float double-float)
     6305     (double-float single-float double-float)))
     6306  "Table used to derive the return type of a numeric operation,
     6307based on the types of the arguments.")
     6308
     6309(defun derive-type-numeric-op (op &rest types)
     6310  "Returns the result type of the numeric operation `op' and the types
     6311of the operation arguments given in `types'."
     6312  (let ((types-table
     6313         (cdr (assoc op numeric-op-type-derivation :test #'member))))
     6314    (assert types-table)
     6315    (flet ((match (type1 type2)
     6316             (do* ((remaining-types types-table (cdr remaining-types)))
     6317                  ((endp remaining-types)
     6318                   ;; when we don't find a matching type, return T
     6319                   T)
     6320               (destructuring-bind
     6321                     (t1 t2 result-type)
     6322                   (car remaining-types)
     6323                 (when (and (or (subtypep type1 t1)
     6324                                (compiler-subtypep type1 t1))
     6325                            (or (subtypep type2 t2)
     6326                                (compiler-subtypep type2 t2)))
     6327                   (return-from match
     6328                     (if (functionp result-type)
     6329                         (funcall result-type op type1 type2)
     6330                         result-type)))))))
     6331      (let ((type1 (car types))
     6332            (type2 (cadr types)))
     6333        (when (and (eq type1 type2)
     6334                   (memq type1 '(SINGLE-FLOAT DOUBLE-FLOAT)))
     6335          (return-from derive-type-numeric-op type1))
     6336        (match type1 type2)))))
     6337
     6338(defvar zero-integer-type (%make-integer-type 0 0)
     6339  "Integer type representing the 0 (zero)
     6340value for use with derive-type-minus.")
     6341
     6342(define-int-bounds-derivation - (low1 high1 low2 high2)
     6343    (values (and low1 low2 (- low1 low2))
     6344            (and high1 high2 (- high1 high2))))
     6345
    62636346(defknown derive-type-minus (t) t)
    62646347(defun derive-type-minus (form)
     
    62676350    (case (length args)
    62686351      (1
    6269        (when-args-integer
    6270   ((%car args))
    6271   (type1 low1 high1)
    6272   ((low (and high1 (- high1)))
    6273    (high (and low1 (- low1))))
    6274   (setf result-type (%make-integer-type low high))))
     6352       (setf result-type
     6353             (derive-type-numeric-op (car form)
     6354                                     zero-integer-type
     6355                                     (derive-compiler-type (%car args)))))
    62756356      (2
    6276        (when-args-integer
    6277   ((%car args) (%cadr args))
    6278   (type1 low1 high1 type2 low2 high2)
    6279   ((low (and low1 high2 (- low1 high2)))
    6280    (high (and high1 low2 (- high1 low2))))
    6281   (setf result-type (%make-integer-type low high)))))
     6357       (setf result-type
     6358             (derive-type-numeric-op (car form)
     6359                                     (derive-compiler-type (car args))
     6360                                     (derive-compiler-type (cadr args))))))
    62826361    result-type))
     6362
     6363
     6364(define-int-bounds-derivation + (low1 high1 low2 high2)
     6365    (values (and low1 low2 (+ low1 low2))
     6366            (and high1 high2 (+ high1 high2))))
    62836367
    62846368(defknown derive-type-plus (t) t)
     
    62876371        (result-type t))
    62886372    (when (= (length args) 2)
    6289       (when-args-integer
    6290        ((%car args) (%cadr args))
    6291        (type1 low1 high1 type2 low2 high2)
    6292        ((low (and low1 low2 (+ low1 low2)))
    6293   (high (and high1 high2 (+ high1 high2))))
    6294        (setf result-type (%make-integer-type low high))))
     6373      (setf result-type
     6374            (derive-type-numeric-op (car form)
     6375                                    (derive-compiler-type (car args))
     6376                                    (derive-compiler-type (cadr args)))))
    62956377    result-type))
    62966378
     
    68596941                        arg2 'stack result-rep)
    68606942              (emit (case result-rep
    6861                       (:int 'iadd)
    6862                       (:long 'ladd)
    6863                       (:float 'fadd)
     6943                      (:int    'iadd)
     6944                      (:long   'ladd)
     6945                      (:float  'fadd)
    68646946                      (:double 'dadd)
    68656947                      (t
     
    69387020                        arg2 'stack result-rep)
    69397021              (emit (case result-rep
    6940                       (:int 'isub)
    6941                       (:long 'lsub)
    6942                       (:float 'fsub)
     7022                      (:int    'isub)
     7023                      (:long   'lsub)
     7024                      (:float  'fsub)
    69437025                      (:double 'dsub)
    69447026                      (t
Note: See TracChangeset for help on using the changeset viewer.