[3d19a6]: src / compiler / generic / vm-type.lisp Maximize Restore History

Download this file

vm-type.lisp    176 lines (153 with data), 6.5 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
;;;; This file contains implementation-dependent parts of the type
;;;; support code. This is stuff which deals with the mapping from
;;;; types defined in Common Lisp to types actually supported by an
;;;; implementation.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!KERNEL")
;;;; FIXME: I'm not sure where to put this. -- WHN 19990817
(deftype sb!vm:word () `(unsigned-byte ,sb!vm:n-word-bits))
;;;; implementation-dependent DEFTYPEs
;;; Make DOUBLE-FLOAT a synonym for LONG-FLOAT, SINGLE-FLOAT for
;;; SHORT-FLOAT. This is expanded before the translator gets a chance,
;;; so we will get precedence.
#!-long-float
(setf (info :type :kind 'long-float) :defined)
#!-long-float
(sb!xc:deftype long-float (&optional low high)
`(double-float ,low ,high))
(setf (info :type :kind 'short-float) :defined)
(sb!xc:deftype short-float (&optional low high)
`(single-float ,low ,high))
;;; an index into an integer
(sb!xc:deftype bit-index () `(integer 0 ,sb!xc:most-positive-fixnum))
;;; worst-case values for float attributes
(sb!xc:deftype float-exponent ()
#!-long-float 'double-float-exponent
#!+long-float 'long-float-exponent)
(sb!xc:deftype float-digits ()
#!-long-float `(integer 0 ,sb!vm:double-float-digits)
#!+long-float `(integer 0 ,sb!vm:long-float-digits))
(sb!xc:deftype float-radix () '(integer 2 2))
(sb!xc:deftype float-int-exponent ()
#!-long-float 'double-float-int-exponent
#!+long-float 'long-float-int-exponent)
;;; a code for BOOLE
(sb!xc:deftype boole-code () '(unsigned-byte 4))
;;; a byte specifier (as generated by BYTE)
(sb!xc:deftype byte-specifier () 'cons)
;;; result of CHAR-INT
(sb!xc:deftype char-int () 'char-code)
;;; PATHNAME pieces, as returned by the PATHNAME-xxx functions
(sb!xc:deftype pathname-host () '(or sb!impl::host null))
(sb!xc:deftype pathname-device ()
'(or simple-string (member nil :unspecific)))
(sb!xc:deftype pathname-directory () 'list)
(sb!xc:deftype pathname-name ()
'(or simple-string sb!impl::pattern (member nil :unspecific :wild)))
(sb!xc:deftype pathname-type ()
'(or simple-string sb!impl::pattern (member nil :unspecific :wild)))
(sb!xc:deftype pathname-version ()
'(or integer (member nil :newest :wild :unspecific)))
;;; internal time format. (Note: not a FIXNUM, ouch..)
(sb!xc:deftype internal-time () 'unsigned-byte)
(sb!xc:deftype bignum-element-type () `(unsigned-byte ,sb!vm:n-word-bits))
(sb!xc:deftype bignum-type () 'bignum)
(sb!xc:deftype bignum-index () 'index)
;;;; hooks into the type system
(sb!xc:deftype unboxed-array (&optional dims)
(collect ((types (list 'or)))
(dolist (type *specialized-array-element-types*)
(when (subtypep type '(or integer character float (complex float)))
(types `(array ,type ,dims))))
(types)))
(sb!xc:deftype simple-unboxed-array (&optional dims)
(collect ((types (list 'or)))
(dolist (type *specialized-array-element-types*)
(when (subtypep type '(or integer character float (complex float)))
(types `(simple-array ,type ,dims))))
(types)))
;;; Return the symbol that describes the format of FLOAT.
(declaim (ftype (function (float) symbol) float-format-name))
(defun float-format-name (x)
(etypecase x
(single-float 'single-float)
(double-float 'double-float)
#!+long-float (long-float 'long-float)))
;;; This function is called when the type code wants to find out how
;;; an array will actually be implemented. We set the
;;; SPECIALIZED-ELEMENT-TYPE to correspond to the actual
;;; specialization used in this implementation.
(declaim (ftype (function (array-type) array-type) specialize-array-type))
(defun specialize-array-type (type)
(let ((eltype (array-type-element-type type)))
(setf (array-type-specialized-element-type type)
(if (or (eq eltype *wild-type*)
;; This is slightly dubious, but not as dubious as
;; assuming that the upgraded-element-type should be
;; equal to T, given the way that the AREF
;; DERIVE-TYPE optimizer works. -- CSR, 2002-08-19
(unknown-type-p eltype))
*wild-type*
(dolist (stype-name *specialized-array-element-types*
*universal-type*)
;; FIXME: Mightn't it be better to have
;; *SPECIALIZED-ARRAY-ELEMENT-TYPES* be stored as precalculated
;; SPECIFIER-TYPE results, instead of having to calculate
;; them on the fly this way? (Call the new array
;; *SPECIALIZED-ARRAY-ELEMENT-SPECIFIER-TYPES* or something..)
(let ((stype (specifier-type stype-name)))
(aver (not (unknown-type-p stype)))
(when (csubtypep eltype stype)
(return stype))))))
type))
(defun sb!xc:upgraded-array-element-type (spec &optional environment)
#!+sb-doc
"Return the element type that will actually be used to implement an array
with the specifier :ELEMENT-TYPE Spec."
(declare (ignore environment))
(if (unknown-type-p (specifier-type spec))
(error "undefined type: ~S" spec)
(type-specifier (array-type-specialized-element-type
(specifier-type `(array ,spec))))))
;;; Return the most specific integer type that can be quickly checked that
;;; includes the given type.
(defun containing-integer-type (subtype)
(dolist (type '(fixnum
(signed-byte 32)
(unsigned-byte 32)
integer)
(error "~S isn't an integer type?" subtype))
(when (csubtypep subtype (specifier-type type))
(return type))))
;;; If TYPE has a CHECK-xxx template, but doesn't have a corresponding
;;; PRIMITIVE-TYPE, then return the template's name. Otherwise, return NIL.
(defun hairy-type-check-template-name (type)
(declare (type ctype type))
(typecase type
(cons-type
(if (type= type (specifier-type 'cons))
'sb!c:check-cons
nil))
(built-in-classoid
(if (type= type (specifier-type 'symbol))
'sb!c:check-symbol
nil))
(numeric-type
(cond ((type= type (specifier-type 'fixnum))
'sb!c:check-fixnum)
((type= type (specifier-type '(signed-byte 32)))
'sb!c:check-signed-byte-32)
((type= type (specifier-type '(unsigned-byte 32)))
'sb!c:check-unsigned-byte-32)
(t nil)))
(fun-type
'sb!c:check-fun)
(t
nil)))