Skip to content
Snippets Groups Projects
Commit a311bb37 authored by phg's avatar phg
Browse files

Changed definition of *subtypep to speed up method definition

using code provided by Richard Harris.
parent 5dc53f49
No related branches found
No related tags found
No related merge requests found
...@@ -361,22 +361,33 @@ ...@@ -361,22 +361,33 @@
(t (t
(typep object (convert-to-system-type type))))) (typep object (convert-to-system-type type)))))
;Writing the missing NOT and AND clauses will improve
;the quality of code generated by generate-discrimination-net, but
;calling subtypep in place of just returning (values nil nil) can be
;very slow. *subtypep is used by PCL itself, and must be fast.
(defun *subtypep (type1 type2) (defun *subtypep (type1 type2)
(if (equal type1 type2) (if (equal type1 type2)
(values t t) (values t t)
(if (eq *boot-state* 'early) (if (eq *boot-state* 'early)
(values (eq type1 type2) t) (values (eq type1 type2) t)
(let ((*in-precompute-effective-methods-p* t)) ; not a descriptive name (let ((*in-precompute-effective-methods-p* t))
(declare (special *in-precompute-effective-methods-p*)) (declare (special *in-precompute-effective-methods-p*))
;; This changes the way class-applicable-using-class-p works. ;; *in-precompute-effective-methods-p* is not a good name.
;; It changes the way class-applicable-using-class-p works.
(setq type1 (*normalize-type type1)) (setq type1 (*normalize-type type1))
(setq type2 (*normalize-type type2)) (setq type2 (*normalize-type type2))
(if (member (car type2) '(eql wrapper-eq class-eq class)) (case (car type2)
(multiple-value-bind (app-p maybe-app-p) (not
(specializer-applicable-using-type-p type2 type1) (values nil nil)) ; Should improve this.
(values app-p (or app-p (not maybe-app-p)))) (and
(subtypep (convert-to-system-type type1) (values nil nil)) ; Should improve this.
(convert-to-system-type type2))))))) ((eql wrapper-eq class-eq class)
(multiple-value-bind (app-p maybe-app-p)
(specializer-applicable-using-type-p type2 type1)
(values app-p (or app-p (not maybe-app-p)))))
(t
(subtypep (convert-to-system-type type1)
(convert-to-system-type type2))))))))
(defun do-satisfies-deftype (name predicate) (defun do-satisfies-deftype (name predicate)
#+(or :Genera (and :Lucid (not :Prime)) ExCL :coral) #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment