TYPE-DIFFERENCE is lame

[Nikodemus Siivola]

In the following function constraint propagator optimizes nothing:

(defun foo (x)
  (declare (integer x))
  (declare (optimize speed))
  (cond ((typep x 'fixnum)
         "hala")
        ((typep x 'fixnum)
         "buba")
        ((typep x 'bignum)
         "hip")
        (t
         "zuz")))

[Nikodemus Siivola (nikodemus)]

This is actually not a constraint propagation issue per se, but a type-system issue.

Our current TYPE-DIFFERENCE is lame. The version below adds just the special case for numeric types, which is enough to allow the compiler to do a better job for this case.

Are there other types than numeric, union, and member types that have interesting differences?

(defun type-difference (x y)
 (if (and (numeric-type-p x) (numeric-type-p y))
    (type-intersection x (type-negation y))
    (let ((x-types (if (union-type-p x) (union-type-types x) (list x)))
          (y-types (if (union-type-p y) (union-type-types y) (list y))))
      (collect ((res))
        (dolist (x-type x-types)
          (if (member-type-p x-type)
              (let ((xset (alloc-xset))
                    (fp-zeroes nil))
                (mapc-member-type-members
                 (lambda (elt)
                   (multiple-value-bind (ok sure) (ctypep elt y)
                     (unless sure
                       (return-from type-difference nil))
                     (unless ok
                       (if (fp-zero-p elt)
                           (pushnew elt fp-zeroes)
                           (add-to-xset elt xset)))))
                 x-type)
                (unless (and (xset-empty-p xset) (not fp-zeroes))
                  (res (make-member-type :xset xset :fp-zeroes fp-zeroes))))
              (dolist (y-type y-types (res x-type))
                (multiple-value-bind (val win) (csubtypep x-type y-type)
                  (unless win (return-from type-difference nil))
                  (when val (return))
                  (when (types-equal-or-intersect x-type y-type)
                    (return-from type-difference nil))))))
        (let ((y-mem (find-if #'member-type-p y-types)))
          (when y-mem
            (dolist (x-type x-types)
              (unless (member-type-p x-type)
                (mapc-member-type-members
                 (lambda (member)
                   (multiple-value-bind (ok sure) (ctypep member x-type)
                     (when (or (not sure) ok)
                       (return-from type-difference nil))))
                 y-mem)))))
        (apply #'type-union (res))))))

[Nikodemus Siivola (nikodemus)]

In SBCL 1.0.36.14.