Re: [Sbcl-help] Compiler bug?

[Nikodemus S. <nik...@ra...>]

On Wed, Jan 9, 2008 at 4:10 AM, Bob Felts <wr...@pa...> wrote:
> This short program, which is about as small as have been able to make
> it and still demonstrate the problem, hangs SBCL.  I'm running SBCL
> 1.0.13.17-x86-darwin on Leopard 10.5.1; although this has been a
> problem with the last several releases, even before I upgraded to
> Leopard.
>
> (defun bug ( )
>   (labels ((foo (upper-limit step)
>             (let ((n (truncate (/ upper-limit step))))
>               (/ (* n (1+ n) step) 2))))
>     (let* ((a (foo 999 3))
>           (b (foo 999 5))
>           (c (foo 999 15)))
>       (- (+ a b) c))))
>
> I'm a rank novice when it comes to playing around in the debugger, but
> it looks like the compiler is stuck in SB-KERNEL::SIMPLIFY-UNIONS.

Not stuck per se, just spending aeons there. Instead of waiting to see
if it finished before heat death of the universe, this should help.

...and people with more then passing acquitance of SBCL's type system
will hopefully point out if I got this wrong.)

(in-package :sb-c)

;;; Take a list of types and return a canonical type specifier,
;;; combining any MEMBER types together. If both positive and negative
;;; MEMBER types are present they are converted to a float type.
;;;
;;; Additionally, convert unions of completely different number types into
;;; vastly simpler types -- there is little point to derive the exact union of
;;; (eg.) exact INTEGER and RATIONAL types for a local function called with
;;; constant argument may have.
(defun make-canonical-union-type (type-list)
  (let ((xset (alloc-xset))
        (fp-zeroes '())
        (misc-types '())
        (classes '())
        (formats '())
        (complexp nil)
        (realp nil))
    (dolist (type type-list)
      (cond ((member-type-p type)
             (mapc-member-type-members
              (lambda (member)
                (if (complexp member)
                    (setf complexp t)
                    (setf realp t))
                (etypecase member
                  ((or float (complex float))
                   (pushnew 'float classes)
                   (etypecase member
                     (single-float (pushnew 'single-float formats))
                     (double-float (pushnew 'double-float formats))))
                  ((or integer (complex integer))
                   (pushnew 'integer classes))
                  ((or rational (complex rational))
                   (pushnew 'rational classes)))
                (if (fp-zero-p member)
                    (unless (member member fp-zeroes)
                      (pushnew member fp-zeroes))
                    (add-to-xset member xset)))
              type))
            ((numeric-type-p type)
             (pushnew (numeric-type-class type) classes)
             (pushnew (numeric-type-format type) formats)
             (ecase (numeric-type-complexp type)
               (:complex
                (setf complexp t))
               (:real
                (setf realp t))
               ((nil)
                (setf complexp t
                      realp t)))
             (push type misc-types))
            (t
             (push type misc-types))))
    (flet ((generic-type (&optional (real 'real))
             (cond ((and complexp realp)
                    (specifier-type `(or ,real (complex ,real))))
                   (realp
                    (specifier-type real))
                   (complexp
                    (specifier-type `(complex ,real)))
                   (t
                    (bug "never")))))
      (cond ((member nil classes)
             (generic-type))
            ((cdr classes)
             (cond ((member 'float classes)
                    (generic-type))
                   (t
                    (generic-type 'rational))))
            (t
             (if (and (xset-empty-p xset) (not fp-zeroes))
                 (apply #'type-union misc-types)
                 (apply #'type-union (make-member-type :xset xset
:fp-zeroes fp-zeroes) misc-types)))))))

...sorry for the tardy reply.

Cheers,

 -- Nikodemus