[Gcl-devel] New type handling in compiler

[Camm Maguire]

Greetings!  Also a quick note here on the latest work -- all types in
the compiler should now be eq unique.  I'm not sure if this is a
performance win, I just got nervous about the type propagation running
afoul of the many old case statements along the line of

(case (var-kind var) (FIXNUM ...) (INTEGER ...))

The types are far richer now, so this is dangerous and had bit me
several times.  It still would be of course possible to replace such
code with 'equal checking on the types, or safer still type>=, but
there were many places relying on eq relationships between symbol
types which I wanted to preserve, perhaps for no good reason.

If anyone sees an "eq prob type2" warning, please let me know.  type>=
and type<= will soon use eq only for their comparisons.  

The current implementation certainly limits consing, but requires two
hash lookups in new type cases.  Not sure if this is optimal in any
way, so I'll post the summary here in case anyone wants to comment:

(defvar *uniq-tp-hash* (make-hash-table :test 'equal))
(defvar *norm-tp-hash* (make-hash-table :test 'eq))

(defun build-tp (tp)
  (cond ((atom tp) tp)
        ((member (car tp) '(and or values cons)) (cons (car tp) (mapcar 
'uniq-tp (cdr tp))))
        ((eq (car tp) 'not) (list (car tp) (uniq-tp (cadr tp))))
        (tp)))

(defun uniq-tp (tp)
  (cond ((gethash tp *uniq-tp-hash*))
        ((let ((tp (build-tp tp)))
           (setf (gethash tp *uniq-tp-hash*) tp)))))

;;resolve-type is the engine behind subtypep, and is costly
(defun dnt (tp)
  (uniq-tp
   (cond ((eq '* tp) '*)
         ((and (consp tp) (eq (car tp) 'values))
          (cond ((not (cdr tp)) nil)
                ((not (cddr tp)) (cmp-norm-tp (cadr tp)))
                (`(values ,@(mapcar 'cmp-norm-tp (cdr tp))))))
         ((let ((tp (resolve-type tp))) (if (cadr tp) '* (car tp)))))))

(defun cmp-norm-tp (tp)
  (multiple-value-bind 
   (r f) (gethash tp *norm-tp-hash*)
   (cond (f r)
         ((let ((tp (uniq-tp tp)))
            (multiple-value-bind 
             (r f) (gethash tp *norm-tp-hash*)
             (cond (f r)
                   ((let ((nt (dnt tp)))
                      (cond ((and (eq '* nt) (not (eq tp '*))) nt)
                            ((setf (gethash tp *norm-tp-hash*) nt (gethash nt 
*norm-tp-hash*) nt))))))))))))

(defmacro uniq-tp-from-stack (op t1 t2)
  (let ((s (gensym)))
    `(let ((,s (list ,op ,t1 ,t2)))
       (declare (:dynamic-extent ,s))
       (uniq-tp ,s))))

(defun type-and (t1 t2)
  (let* ((x  (uniq-tp-from-stack `and t1 t2)))
    (multiple-value-bind 
        (r f) (gethash x *norm-tp-hash*)
      (cond (f r)
            ((setf (gethash x *norm-tp-hash*) (type-and-int t1 t2)))))))

(defun type-or1 (t1 t2)
  (let ((x  (uniq-tp-from-stack `or t1 t2)))
    (multiple-value-bind 
     (r f) 
     (gethash x *norm-tp-hash*)
     (cond (f r)
           ((setf (gethash x *norm-tp-hash*) (type-or1-int t1 t2)))))))

(defun type-and-int (type1 type2)
  (cond ((eq type1 '*) type2)
        ((eq type2 '*) type1)
        ((equal type1 type2) type2)
        ((or (vt type1) (vt type2))
         (let* ((ntype1 (if (vt type1) type1 `(values ,@(when type1 (list 
type1)))))
                (ntype2 (if (vt type2) type2 `(values ,@(when type2 (list 
type2)))))
                (l1 (length ntype1))
                (l2 (length ntype2)))
           (cond ((and (every 'type>= (cdr ntype1) (cdr ntype2)) (>= l1 l2)) 
type2)
                 ((and (every 'type>= (cdr ntype2) (cdr ntype1)) (>= l2 l1)) 
type1)
                 ((cmp-norm-tp `(values ,@(mapcar 'type-and (cdr ntype1) (cdr 
ntype2))))))))
        ((member type1 '(t object)) type2)
        ((member type2 '(t object)) type1)
        ((subtypep1 type2 type1) type2)
        ((subtypep1 type1 type2) type1)
        ((cmp-norm-tp `(and ,type1 ,type2)))))

(defun type-or1-int (type1 type2)
  (cond ((eq type1 '*) type1)
        ((eq type2 '*) type2)
        ((or (and (consp type1) (eq (car type1) 'values))
             (and (consp type2) (eq (car type2) 'values)))
         (let* ((ntype1 (if (vt type1) type1 `(values ,@(when type1 (list 
type1)))))
                (ntype2 (if (vt type2) type2 `(values ,@(when type2 (list 
type2)))))
                (l1 (length ntype1))
                (l2 (length ntype2))
                (n (- (max l1 l2) (min l1 l2)))
                (e (make-list n :initial-element #tnull))
                (ntype1 (if (< l1 l2) (append ntype1 e) ntype1))
                (ntype2 (if (< l2 l1) (append ntype2 e) ntype2)))
           (cond ((and (every 'type>= (cdr ntype2) (cdr ntype1)) (>= l2 l1)) 
type2)
                 ((and (every 'type>= (cdr ntype1) (cdr ntype2)) (>= l1 l2)) 
type1)
                 ((cmp-norm-tp `(values ,@(mapcar 'type-or1 (cdr ntype1) (cdr 
ntype2))))))))
        ((equal type1 type2) type2)
        ((member type1 '(t object)) type1)
        ((member type2 '(t object)) type2)
        ((subtypep1 type1 type2) type2)
        ((subtypep1 type2 type1) type1)
        ((type-filter `(or ,type1 ,type2)))))

(defun type>= (type1 type2)
    (let ((z (type-and t1 t2)))
      (when (and (equal z t2) (not (eq z t2))) (cmpwarn "eq type2 prob: ~s 
~s~%" t1 t2))
                                        ;    (when (not (eq type1 (cmp-norm-tp 
type1))) (cmpwarn "unnorm type1 ~s~%" type1))
                                        ;    (when (not (eq type2 (cmp-norm-tp 
type2))) (cmpwarn "unnorm type2 ~s~%" type2))
      (equal z t2)))

(defun type<= (type1 type2)
    (let ((z (type-and t2 t1)))
      (when (and (equal z t1) (not (eq z t1))) (cmpwarn "eq type1 prob: ~s 
~s~%" t1 t2))
                                        ;    (when (not (eq type1 (cmp-norm-tp 
type1))) (cmpwarn "unnorm type1 ~s~%" type1))
                                        ;    (when (not (eq type2 (cmp-norm-tp 
type2))) (cmpwarn "unnorm type2 ~s~%" type2))
      (equal z t1)))

'* is the supertype for everything, including multiple values.
'object needs to be purged.

Also, I've used reader macros to ensure load-time eq uniqueness of
constants:  

(defun sharp-t-reader (stream subchar arg)
  (declare (ignore subchar arg))
  `(load-time-value (cmp-norm-tp ',(read stream))))
(defun sharp-l-reader (stream subchar arg)
  (declare (ignore subchar arg))
  `(load-time-value (mapcar 'cmp-norm-tp ',(read stream))))
(defun sharp-y-reader (stream subchar arg)
  (declare (ignore subchar arg))
  `(load-time-value (mapcar (lambda (x) (cons (cmp-norm-tp (car x)) (cdr x))) 
',(read stream))))

This is probably too much and needs replacing with simple macros.  A
question of taste, of which I have none :-).

Take care,

--
Camm Maguire                                            address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens."  --  Baha'u'llah