Skip to content
Snippets Groups Projects
Commit 5296088e authored by wlott's avatar wlott
Browse files

Moved *type-predicate* and *predicate-type* into the backend structure.

parent c39cf67c
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/checkgen.lisp,v 1.18 1991/03/18 20:54:43 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/checkgen.lisp,v 1.19 1992/03/21 19:41:14 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -61,7 +61,8 @@ ...@@ -61,7 +61,8 @@
(or (let ((check (type-check-template type))) (or (let ((check (type-check-template type)))
(if check (if check
(template-cost check) (template-cost check)
(let ((found (cdr (assoc type *type-predicates* :test #'type=)))) (let ((found (cdr (assoc type (backend-type-predicates *backend*)
:test #'type=))))
(if found (if found
(+ (function-cost found) (function-cost 'eq)) (+ (function-cost found) (function-cost 'eq))
nil)))) nil))))
...@@ -108,7 +109,7 @@ ...@@ -108,7 +109,7 @@
(let ((min-cost (type-test-cost type)) (let ((min-cost (type-test-cost type))
(min-type type) (min-type type)
(found-super nil)) (found-super nil))
(dolist (x *type-predicates*) (dolist (x (backend-type-predicates *backend*))
(let ((stype (car x))) (let ((stype (car x)))
(when (and (csubtypep type stype) (when (and (csubtypep type stype)
(not (union-type-p stype))) ;Not #!% COMMON type. (not (union-type-p stype))) ;Not #!% COMMON type.
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/constraint.lisp,v 1.11 1991/12/08 17:24:51 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/constraint.lisp,v 1.12 1992/03/21 19:41:31 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -197,7 +197,7 @@ ...@@ -197,7 +197,7 @@
var2 (continuation-type arg1) var2 (continuation-type arg1)
nil)))) nil))))
(t (t
(let ((ptype (gethash name *predicate-types*))) (let ((ptype (gethash name (backend-predicate-types *backend*))))
(when ptype (when ptype
(add-complement-constraints if 'typep (add-complement-constraints if 'typep
(ok-cont-lambda-var (first args)) (ok-cont-lambda-var (first args))
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.12 1991/10/24 21:05:00 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.13 1992/03/21 19:41:34 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -34,18 +34,11 @@ ...@@ -34,18 +34,11 @@
;;; corresponding predicates) are not maintained in this association. In this ;;; corresponding predicates) are not maintained in this association. In this
;;; case, there need not be any predicate function unless it is required by ;;; case, there need not be any predicate function unless it is required by
;;; Common Lisp. ;;; Common Lisp.
;;; These two variables maintain the translation between types and predicates.
;;; *Predicate-Types* is a hashtable that translates from type predicate names
;;; to CType objects. *Type-Predicates* is an alist (<type> . <predicate>)
;;; that translates from types to predicates. We can't use a hashtable, since
;;; there is no such thing as a Type= hashtable. Establishing this translation
;;; ;;;
(defvar *predicate-types* (make-hash-table :test #'eq)) ;;; The mappings between predicates and type structures is stored in the
(proclaim '(hash-table *predicate-types*)) ;;; backend structure, so that different backends can support different sets
(defvar *type-predicates* ()) ;;; of predicates.
(proclaim '(list *type-predicates*)) ;;;
;;; Define-Type-Predicate -- Interface ;;; Define-Type-Predicate -- Interface
;;; ;;;
...@@ -54,14 +47,17 @@ ...@@ -54,14 +47,17 @@
Establish an association between the type predicate Name and the Establish an association between the type predicate Name and the
corresponding Type. This causes the type predicate to be recognized for corresponding Type. This causes the type predicate to be recognized for
purposes of optimization." purposes of optimization."
`(progn `(%define-type-predicate ',name ',type))
(setf (gethash ',name *predicate-types*) (specifier-type ',type)) ;;;
(setq *type-predicates* (defun %define-type-predicate (name specifier)
(cons (cons (specifier-type ',type) ',name) (let ((type (specifier-type specifier)))
(remove ',name *type-predicates* :key #'cdr))) (setf (gethash name (backend-predicate-types *target-backend*)) type)
(%deftransform ',name '(function (t) *) #'fold-type-predicate) (setf (backend-type-predicates *target-backend*)
',name)) (cons (cons type name)
(remove name (backend-type-predicates *target-backend*)
:key #'cdr)))
(%deftransform name '(function (t) *) #'fold-type-predicate)
name))
;;;; IR1 transforms: ;;;; IR1 transforms:
...@@ -114,35 +110,39 @@ ...@@ -114,35 +110,39 @@
(ref-leaf (ref-leaf
(continuation-use (continuation-use
(basic-combination-fun node)))) (basic-combination-fun node))))
*predicate-types*))) (backend-predicate-types *backend*))))
(assert ctype) (assert ctype)
(ir1-transform-type-predicate object ctype))) (ir1-transform-type-predicate object ctype)))
;;;; Standard type predicates: ;;;; Standard type predicates:
(define-type-predicate arrayp array) (defun define-standard-type-predicates ()
; No atom. Use (not cons) deftype. (define-type-predicate arrayp array)
(define-type-predicate bit-vector-p bit-vector) ; No atom. Use (not cons) deftype.
(define-type-predicate characterp character) (define-type-predicate bit-vector-p bit-vector)
(define-type-predicate compiled-function-p compiled-function) (define-type-predicate characterp character)
(define-type-predicate complexp complex) (define-type-predicate compiled-function-p compiled-function)
(define-type-predicate consp cons) (define-type-predicate complexp complex)
(define-type-predicate floatp float) (define-type-predicate consp cons)
(define-type-predicate functionp function) (define-type-predicate floatp float)
(define-type-predicate integerp integer) (define-type-predicate functionp function)
(define-type-predicate keywordp keyword) (define-type-predicate integerp integer)
(define-type-predicate listp list) (define-type-predicate keywordp keyword)
(define-type-predicate null null) (define-type-predicate listp list)
(define-type-predicate numberp number) (define-type-predicate null null)
(define-type-predicate rationalp rational) (define-type-predicate numberp number)
(define-type-predicate simple-bit-vector-p simple-bit-vector) (define-type-predicate rationalp rational)
(define-type-predicate simple-string-p simple-string) (define-type-predicate simple-bit-vector-p simple-bit-vector)
(define-type-predicate simple-vector-p simple-vector) (define-type-predicate simple-string-p simple-string)
(define-type-predicate stringp string) (define-type-predicate simple-vector-p simple-vector)
(define-type-predicate structurep structure) (define-type-predicate stringp string)
(define-type-predicate symbolp symbol) (define-type-predicate structurep structure)
(define-type-predicate vectorp vector) (define-type-predicate symbolp symbol)
(define-type-predicate vectorp vector))
(define-standard-type-predicates)
;;;; Transforms for type predicates not implemented primitively: ;;;; Transforms for type predicates not implemented primitively:
...@@ -284,7 +284,7 @@ ...@@ -284,7 +284,7 @@
(declare (type ctype type)) (declare (type ctype type))
(let ((res nil) (let ((res nil)
(res-type nil)) (res-type nil))
(dolist (x *type-predicates*) (dolist (x (backend-type-predicates *backend*))
(let ((stype (car x))) (let ((stype (car x)))
(when (and (csubtypep type stype) (when (and (csubtypep type stype)
(or (not res-type) (or (not res-type)
...@@ -392,7 +392,8 @@ ...@@ -392,7 +392,8 @@
(def-source-transform typep (object spec) (def-source-transform typep (object spec)
(if (and (consp spec) (eq (car spec) 'quote)) (if (and (consp spec) (eq (car spec) 'quote))
(let* ((type (specifier-type (cadr spec))) (let* ((type (specifier-type (cadr spec)))
(pred (cdr (assoc type *type-predicates* :test #'type=)))) (pred (cdr (assoc type (backend-type-predicates *backend*)
:test #'type=))))
(if pred (if pred
`(,pred ,object) `(,pred ,object)
(typecase type (typecase type
......
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