source: trunk/abcl/src/org/armedbear/lisp/compiler-types.lisp

Last change on this file was 15037, checked in by Mark Evenson, 7 years ago

Fix MAX type derivation
(Olof-Joachim Frahm)

C.f. <​http://abcl.org/trac/ticket/258>.

From <​https://github.com/Ferada/abcl/commit/013fb56d5c5fc4d4837ffc4c67e9909db56cbabf>.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 9.9 KB
Line 
1;;; compiler-types.lisp
2;;;
3;;; Copyright (C) 2005-2006 Peter Graves
4;;; $Id: compiler-types.lisp 15037 2017-06-03 04:35:50Z mevenson $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32;;; Type information that matters to the compiler.
33
34(in-package #:system)
35
36(export '(+true-type+
37          +false-type+
38          integer-type-low
39          integer-type-high
40          integer-type-p
41          %make-integer-type
42          make-integer-type
43          +fixnum-type+
44          +integer-type+
45          fixnum-type-p
46          fixnum-constant-value
47          integer-constant-value
48          java-long-type-p
49          make-compiler-type
50          compiler-subtypep
51          function-result-type
52          defknown))
53
54(defstruct constant-type value)
55
56(defconst +true-type+ (make-constant-type :value t))
57
58(defconst +false-type+ (make-constant-type :value nil))
59
60(defstruct (integer-type (:constructor %make-integer-type (low high)))
61  low
62  high)
63
64(defmethod print-object ((type integer-type) stream)
65  (print-unreadable-object (type stream :type t :identity t)
66    (format stream "~D ~D" (integer-type-low type) (integer-type-high type))))
67
68(defconstant +fixnum-type+  (%make-integer-type most-negative-fixnum
69                                                most-positive-fixnum))
70
71(defconstant +integer-type+ (%make-integer-type nil nil))
72
73(declaim (ftype (function (t) t) make-integer-type))
74(defun make-integer-type (type)
75  (if (integer-type-p type)
76      type
77      (cond ((eq type 'FIXNUM)
78             +fixnum-type+)
79            ((eq type 'INTEGER)
80             +integer-type+)
81            (t
82             (setf type (normalize-type type))
83             (when (and (consp type) (eq (%car type) 'INTEGER))
84               (let ((low (second type))
85                     (high (third type)))
86                 (if (eq low '*)
87                     (setf low nil)
88                     (when (and (consp low) (integerp (%car low)))
89                       (setf low (1+ (%car low)))))
90                 (if (eq high '*)
91                     (setf high nil)
92                     (when (and (consp high) (integerp (%car high)))
93                       (setf high (1- (%car high)))))
94                 (%make-integer-type low high)))))))
95
96(declaim (ftype (function (t) t) fixnum-type-p))
97(defun fixnum-type-p (compiler-type)
98  (and (integer-type-p compiler-type)
99       (fixnump (integer-type-low compiler-type))
100       (fixnump (integer-type-high compiler-type))))
101
102(declaim (ftype (function (t) t) fixnum-constant-value))
103(defun fixnum-constant-value (compiler-type)
104  (when (and compiler-type (integer-type-p compiler-type))
105    (let ((low (integer-type-low compiler-type))
106          high)
107      (when (fixnump low)
108        (setf high (integer-type-high compiler-type))
109        (when (and (fixnump high) (= high low))
110          high)))))
111
112(declaim (ftype (function (t) t) integer-constant-value))
113(defun integer-constant-value (compiler-type)
114  (when (and compiler-type (integer-type-p compiler-type))
115    (let ((low (integer-type-low compiler-type))
116          high)
117      (when (integerp low)
118        (setf high (integer-type-high compiler-type))
119        (when (and (integerp high) (= high low))
120          high)))))
121
122(declaim (ftype (function (t) t) java-long-type-p))
123(defun java-long-type-p (compiler-type)
124  (and (integer-type-p compiler-type)
125       (typep (integer-type-low compiler-type)
126              (list 'INTEGER most-negative-java-long most-positive-java-long))
127       (typep (integer-type-high compiler-type)
128              (list 'INTEGER most-negative-java-long most-positive-java-long))))
129
130
131(declaim (ftype (function (t t) t) make-union-type))
132(defun make-union-type (type1 type2)
133  (cond ((and (integer-type-p type1)
134              (integer-type-p type2))
135         (let ((low1 (integer-type-low type1))
136               (low2 (integer-type-low type2))
137               (high1 (integer-type-high type1))
138               (high2 (integer-type-high type2)))
139           (if (and low1 low2 high1 high2)
140               (%make-integer-type (min low1 low2) (max high1 high2))
141               +integer-type+)))
142        (t
143         t)))
144
145(declaim (ftype (function (t) t) make-compiler-type))
146(defun make-compiler-type (typespec)
147  (cond ((integer-type-p typespec)
148         typespec)
149        ((constant-type-p typespec)
150         typespec)
151        ((eq typespec 'SINGLE-FLOAT)
152         'SINGLE-FLOAT)
153        ((eq typespec 'DOUBLE-FLOAT)
154         'DOUBLE-FLOAT)
155        ((and (consp typespec)
156              (eq (%car typespec) 'SINGLE-FLOAT))
157         'SINGLE-FLOAT)
158        ((and (consp typespec)
159              (eq (%car typespec) 'DOUBLE-FLOAT))
160         'DOUBLE-FLOAT)
161        (t
162         (let ((type (normalize-type typespec)))
163           (cond ((consp type)
164                  (let ((car (%car type)))
165                    (cond ((eq car 'INTEGER)
166                           (make-integer-type type))
167                          ((eq car 'SINGLE-FLOAT)
168                           'SINGLE-FLOAT)
169                          ((eq car 'DOUBLE-FLOAT)
170                           'DOUBLE-FLOAT)
171                          ((memq car '(STRING SIMPLE-STRING LIST))
172                           car)
173                          ((memq car '(VECTOR SIMPLE-VECTOR ARRAY SIMPLE-ARRAY))
174                           type)
175                          ((eq car 'OR)
176                           (case (length (cdr type))
177                             (1
178                              (make-compiler-type (second type)))
179                             (2
180                              (make-union-type (make-compiler-type (second type))
181                                               (make-compiler-type (third type))))
182                             (t
183                              t)))
184                          ((subtypep type 'FIXNUM)
185                           +fixnum-type+)
186                          (t
187                           t))))
188                 ((memq type '(BOOLEAN CHARACTER HASH-TABLE STREAM SYMBOL))
189                  type)
190                 ((eq type 'INTEGER)
191                  (%make-integer-type nil nil))
192                 (t
193                  t))))))
194
195(defun integer-type-subtypep (type1 typespec)
196  (if (eq typespec 'INTEGER)
197      t
198      (let ((type2 (make-integer-type typespec)))
199        (when type2
200          (let ((low1 (integer-type-low type1))
201                (high1 (integer-type-high type1))
202                (low2 (integer-type-low type2))
203                (high2 (integer-type-high type2)))
204            (cond ((and low1 low2 high1 high2)
205                   (and (>= low1 low2) (<= high1 high2)))
206                  ((and low1 low2 (< low1 low2))
207                   nil)
208                  ((and high1 high2) (> high1 high2)
209                   nil)
210                  ((and (null low1) low2)
211                   nil)
212                  ((and (null high1) high2)
213                   nil)
214                  (t
215                   t)))))))
216
217(declaim (ftype (function (t t) t) compiler-subtypep))
218(defun compiler-subtypep (compiler-type typespec)
219  (cond ((eq typespec t)
220         t)
221        ((eq compiler-type t)
222         nil)
223        ((eq compiler-type typespec)
224         t)
225        ((eq typespec 'STRING)
226         (eq compiler-type 'SIMPLE-STRING))
227        ((integer-type-p compiler-type)
228         (integer-type-subtypep compiler-type typespec))
229        (t
230         (values (subtypep compiler-type typespec)))))
231
232(declaim (type hash-table *function-result-types*))
233(defvar *function-result-types* (make-hash-table :test 'equal))
234
235(declaim (ftype (function (t) t) function-result-type))
236(defun function-result-type (name)
237  (if (symbolp name)
238      (get name 'function-result-type)
239      (gethash1 name *function-result-types*)))
240
241(declaim (ftype (function (t t) t) set-function-result-type))
242(defun set-function-result-type (name result-type)
243  (if (symbolp name)
244      (setf (get name 'function-result-type) result-type)
245      (setf (gethash name *function-result-types*) result-type)))
246
247(defun %defknown (name-or-names argument-types result-type)
248  (let ((ftype `(function ,argument-types ,result-type))
249        (result-type (make-compiler-type result-type)))
250    (cond ((or (symbolp name-or-names) (setf-function-name-p name-or-names))
251           (proclaim-ftype-1 ftype name-or-names)
252           (set-function-result-type name-or-names result-type))
253          (t
254           (proclaim-ftype ftype name-or-names)
255           (dolist (name name-or-names)
256             (set-function-result-type name result-type)))))
257  name-or-names)
258
259(defmacro defknown (name-or-names argument-types result-type)
260  `(eval-when (:compile-toplevel :load-toplevel :execute)
261     (%defknown ',name-or-names ',argument-types ',result-type)))
262
263(provide '#:compiler-types)
Note: See TracBrowser for help on using the repository browser.