source: trunk/source/compiler/acode-rewrite.lisp @ 16127

Last change on this file since 16127 was 16127, checked in by gb, 5 years ago

Be more careful about the fact that BOUNDED-INTEGER-TYPE-FOR-xxx can return
NIL: don't call SPECIFIER-TYPE on NIL (fixes ticket:1206), and don't treat
a null returned value as if it was an accurate representation of the result
type.

File size: 42.8 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2007-2010 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19
20(defvar *acode-rewrite-tail-allow* nil)
21(defvar *acode-rewrite-reckless* nil)
22(defvar *acode-rewrite-open-code-inline* nil)
23(defvar *acode-rewrite-trust-declarations* nil)
24(defvar *acode-rewrite-full-safety* nil)
25
26
27;;; Rewrite acode trees.
28
29(defvar *acode-rewrite-functions* nil)
30(let* ((newsize (%i+ (next-nx-num-ops) 10))
31       (old *acode-rewrite-functions*)
32       (oldsize (length old)))
33  (declare (fixnum newsize oldsize))
34  (unless (>= oldsize newsize)
35    (let* ((v (make-array newsize :initial-element nil)))
36      (dotimes (i oldsize (setq *acode-rewrite-functions* v))
37        (setf (svref v i) (svref old i))))))
38
39(eval-when (:compile-toplevel :load-toplevel :execute)
40  (defmacro def-acode-rewrite (name operator-list type-name arglist &body body)
41    (when (atom operator-list)
42      (setq operator-list (list operator-list)))
43    (multiple-value-bind (lambda-list whole-var) (normalize-lambda-list arglist t)
44      (unless whole-var (setq whole-var (gensym)))
45      (multiple-value-bind (body decls)
46          (parse-body body nil t)
47        (collect ((let-body))
48          (dolist (operator operator-list)
49            (let-body `(setf (svref *acode-rewrite-functions* (logand operator-id-mask (%nx1-operator ,operator))) fun)))
50          (let* ((operands (gensym "OPERANDS")))
51            (multiple-value-bind (bindings binding-decls)
52                (%destructure-lambda-list lambda-list operands nil nil
53                                          :cdr-p nil
54                                          :whole-p nil
55                                          :use-whole-var t
56                                          :default-initial-value nil)
57             
58              `(let* ((fun (nfunction ,name 
59                                      (lambda (,whole-var &optional (,type-name t))
60                                        (declare (ignorable ,type-name))
61                                        (block ,name
62                                          (let* ((,operands (acode-operands ,whole-var))
63                                                 ,@(nreverse bindings))
64                                            ,@(when binding-decls `((declare ,@binding-decls)))
65                                            ,@decls
66                                            ,@body))))))
67          ,@(let-body)))))))))
68
69
70
71(defun rewrite-acode-form (form &optional (type t))
72  (when (acode-p form)
73    (let* ((op (acode-operator form))
74           (rewrite (svref *acode-rewrite-functions* (logand op operator-id-mask))))
75      (if rewrite
76        (funcall rewrite form type)
77        (if (logbitp operator-acode-subforms-bit op)
78          (dolist (operand (acode-operands form))
79            (rewrite-acode-form operand))
80          (format t "~&can't rewrite ~s : ~s" (acode-operator-name op) form))))))
81
82(defun acode-wrap-in-unary-op (form op)
83  (let* ((new (make-acode* (acode-operator form) (acode-operands form))))
84    (setf (acode-operator form) op
85          (acode-operands form) (list new)
86          (acode.asserted-type form) nil)
87    form))
88
89   
90(defun acode-rewrite-as-constant-ref (form constant)
91  (case constant
92    (nil (setf (acode-operator form) (%nx1-operator nil)
93               (acode-operands form) nil))
94    ((t) (setf (acode-operator form) (%nx1-operator t)
95               (acode-operands form) nil))
96    (t
97     (setf (acode-operator form) (if (nx1-target-fixnump constant)
98                     (%nx1-operator fixnum)
99                     (%nx1-operator immediate))
100           (car (acode-operands form)) constant
101           (cdr (acode-operands form)) nil)) )
102  (setf (acode.asserted-type form) nil)
103  t)
104 
105(defun acode-constant-fold-numeric-binop (whole form1 form2 function)
106  (rewrite-acode-form form1)
107  (rewrite-acode-form form2)
108  (let* ((v1 (acode-xxx-form-p form1 'number))
109         (v2 (acode-xxx-form-p form2 'number))
110         (val (and v1 v2 (ignore-errors (funcall function v1 v2)))))
111    (when val
112      (acode-rewrite-as-constant-ref whole val))))
113
114(defun acode-strength-reduce-binop (whole form1 form2 type high low)
115  (declare (fixnum high low))
116  (when (and (eql (acode-operator whole) high)
117             (acode-form-typep form1 type *acode-rewrite-trust-declarations*)
118             (acode-form-typep form2 type *acode-rewrite-trust-declarations*))
119    (setf (acode.asserted-type whole) nil
120          (acode-operator whole) low)))
121
122(defun acode-rewrite-decls (decls)
123  (if (fixnump decls)
124    (locally (declare (fixnum decls))
125      (setq *acode-rewrite-tail-allow* (neq 0 (%ilogand2 $decl_tailcalls decls))
126            *acode-rewrite-open-code-inline* (neq 0 (%ilogand2 $decl_opencodeinline decls))
127            *acode-rewrite-full-safety* (neq 0 (%ilogand2 $decl_full_safety decls))
128            *acode-rewrite-reckless* (neq 0 (%ilogand2 $decl_unsafe decls))
129            *acode-rewrite-trust-declarations* (neq 0 (%ilogand2 $decl_trustdecls decls))))))
130
131(defmacro with-acode-declarations (declsform &body body)
132  `(let* ((*acode-rewrite-tail-allow* *acode-rewrite-tail-allow*)
133          (*acode-rewrite-reckless* *acode-rewrite-reckless*)
134          (*acode-rewrite-open-code-inline* *acode-rewrite-open-code-inline*)
135          (*acode-rewrite-trust-declarations* *acode-rewrite-trust-declarations*)
136          (*acode-rewrite-full-safety* *acode-rewrite-full-safety*))
137     (acode-rewrite-decls ,declsform)
138     ,@body))
139
140(defun acode-maybe-punt-var (var initform)
141  (let* ((bits (nx-var-bits var)))
142    (declare (fixnum bits))
143    (cond ((and (logbitp $vbitpuntable bits)
144                (not (logbitp $vbitpunted bits)))
145           (nx-set-var-bits var (logior (ash 1 $vbitpunted) bits))
146           (rewrite-acode-form initform (or (var-declared-type var) t))
147           (nx2-replace-var-refs var initform)
148           (setf (var-ea var) initform))
149          (t
150           (rewrite-acode-form initform)))))
151
152(def-acode-rewrite acode-rewrite-not not asserted-type (&whole w cc form)
153  (rewrite-acode-form form)
154  (multiple-value-bind (val constantp) (acode-constant-p form)
155    (when constantp
156      (let* ((condition (car (acode-operands cc))))
157        (setf (acode-operator w)
158              (if (or (and (eq condition :eq) (null val))
159                      (and (eq condition :ne) (not (null val))))
160                (%nx1-operator t)
161                (%nx1-operator nil))
162              (acode.asserted-type w) nil
163              (acode-operands w) nil)))))
164
165(defun acode-rewrite-binop-for-numeric-contagion (form1 form2 trust-decls)
166  (rewrite-acode-form form1)
167  (rewrite-acode-form form2)
168  (cond ((acode-form-typep form1 'double-float trust-decls)
169         (unless (acode-form-typep form2 'double-float trust-decls)
170           (let* ((c2 (acode-real-constant-p form2)))
171             (if c2
172               (setf (acode-operator form2) (%nx1-operator immediate)
173                     (acode-operands form2) (cons (float c2 0.0d0) nil))
174               (if (acode-form-typep form2 'fixnum trust-decls)
175                 (acode-wrap-in-unary-op form2 (%nx1-operator %fixnum-to-double)))))))
176        ((acode-form-typep form2 'double-float trust-decls)
177         (let* ((c1 (acode-real-constant-p form1)))
178           (if c1
179               (setf (acode-operator form1) (%nx1-operator immediate)
180                     (acode-operands form1) (cons (float c1 0.0d0) nil))
181             (if (acode-form-typep form1 'fixnum trust-decls)
182               (acode-wrap-in-unary-op form1 (%nx1-operator %fixnum-to-double))))))
183        ((acode-form-typep form1 'single-float trust-decls)
184         (unless (acode-form-typep form2 'single-float trust-decls)
185           (let* ((c2 (acode-real-constant-p form2)))
186             (if c2
187               (setf (acode-operator form2) (%nx1-operator immediate)
188                     (acode-operands form2) (cons (float c2 0.0f0) nil))
189               (if (acode-form-typep form2 'fixnum trust-decls)
190                 (acode-wrap-in-unary-op form2 (%nx1-operator %fixnum-to-single)))))))
191        ((acode-form-typep form2 'single-float trust-decls)
192         (let* ((c1 (acode-real-constant-p form1)))
193             (if c1
194               (setf (acode-operator form1) (%nx1-operator immediate)
195                     (acode-operands form1) (cons (float c1 0.0f0) nil))
196               (if (acode-form-typep form1 'fixnum trust-decls)
197                 (acode-wrap-in-unary-op form1 (%nx1-operator %fixnum-to-single))))))))
198 
199(def-acode-rewrite acode-rewrite-add2 add2 asserted-type (&whole w form1 form2)
200  (let* ((trust-decls *acode-rewrite-trust-declarations*))
201    (acode-rewrite-binop-for-numeric-contagion form1 form2 trust-decls)
202    (or (acode-constant-fold-numeric-binop w form1 form2 '+)
203        (let* ((target-fixnum-type *nx-target-fixnum-type*)               
204               (target-natural-type *nx-target-natural-type*)
205               (t1 (acode-form-type form1 trust-decls))
206               (t2 (acode-form-type form2 trust-decls))
207               (newtype nil)
208               (newop (cond ((and (subtypep t1 'double-float)
209                                  (subtypep t2 'double-float))
210                             (setq newtype 'double-float)
211                             (%nx1-operator %double-float+-2))
212                            ((and (subtypep t1 'single-float)
213                                  (subtypep t2 'single-float))
214                             (setq newtype 'single-float)
215                             (%nx1-operator %short-float+-2))
216
217                            ((and (subtypep t1 target-fixnum-type)
218                                  (subtypep t2 target-fixnum-type))
219                             (setq newtype (or (ctype-specifier (bounded-integer-type-for-addition t1 t2)) 'integer))
220                             (if (or
221                                  (subtypep newtype target-fixnum-type)
222                                  (and trust-decls
223                                      (subtypep asserted-type target-fixnum-type)))
224                               (%nx1-operator fixnum-add-no-overflow)
225                               (%nx1-operator fixnum-add-overflow)))
226                            ((and (subtypep t1 target-natural-type)
227                                  (subtypep t2 target-natural-type)
228                                  (or (subtypep (setq newtype (or (ctype-specifier (bounded-integer-type-for-addition t1 t2)) 'unsigned-byte)) target-natural-type)
229                                      (and trust-decls
230                                           (subtypep asserted-type target-natural-type))))
231                             (%nx1-operator %natural+)))))
232          (when newop
233            (setf (acode.asserted-type w) newtype
234                  (acode-operator w) newop))))))
235
236(def-acode-rewrite acode-rewrite-sub2 sub2 asserted-type (&whole w form1 form2)
237  (let* ((trust-decls *acode-rewrite-trust-declarations*))
238    (acode-rewrite-binop-for-numeric-contagion form1 form2 trust-decls)
239    (or (acode-constant-fold-numeric-binop w form1 form2 '-)
240        (let* ((target-fixnum-type *nx-target-fixnum-type*)
241               (target-natural-type *nx-target-natural-type*)
242               (newtype nil)
243               (t1 (acode-form-type form1 trust-decls))
244               (t2 (acode-form-type form2 trust-decls))
245               (newop (cond ((and (subtypep t1 'double-float)
246                                  (subtypep t2 'double-float))
247                             (setq newtype 'double-float)
248                             (%nx1-operator %double-float--2))
249                            ((and (subtypep t1 'single-float)
250                                  (subtypep t2 'single-float))
251                             (setq newtype 'single-float)
252                             (%nx1-operator %short-float--2))
253
254                            ((and (subtypep t1 target-fixnum-type)
255                                  (subtypep t2 target-fixnum-type))
256                             (if (or (subtypep (setq newtype
257                                                     (or
258                                                      (ctype-specifier
259                                                       (bounded-integer-type-for-subtraction t1 t2))
260                                                      'integer))
261                   target-fixnum-type)
262
263                                     (and trust-decls
264                                          (subtypep asserted-type target-fixnum-type)))
265                               (%nx1-operator fixnum-sub-no-overflow)
266                               (%nx1-operator fixnum-sub-overflow)))
267                            ((and (subtypep t1 target-natural-type)
268                                  (subtypep t2 target-natural-type)
269                                  (or (subtypep (setq newtype
270                                                      (or
271                                                       (ctype-specifier
272                                                       (bounded-integer-type-for-subtraction t1 t2)) 'integer))
273                                                target-natural-type)
274                                      (and trust-decls
275                                           (subtypep asserted-type target-natural-type))))
276                             (%nx1-operator %natural-)))))
277          (when newop
278            (setf (acode.asserted-type w) newtype
279                  (acode-operator w) newop))))))
280
281
282(def-acode-rewrite acode-rewrite-mul2 mul2 asserted-type (&whole w form1 form2)
283  (let* ((trust-decls *acode-rewrite-trust-declarations*))
284    (acode-rewrite-binop-for-numeric-contagion form1 form2 trust-decls)
285    (or (acode-constant-fold-numeric-binop w form1 form2 '*)
286        (let* ((t1 (acode-form-type form1 trust-decls))
287               (t2 (acode-form-type form2 trust-decls))
288               (c1 (acode-fixnum-form-p form1))
289               (c2 (acode-fixnum-form-p form2))
290               (shift-count nil))
291          (cond ((and c1 (> c1 0) (< c1 (ash 1 24)) (eql (logcount c1) 1)
292                      (acode-form-typep form2 'integer trust-decls))
293                 (setq shift-count (1- (integer-length c1)))
294                 (setf (acode-operator w) (%nx1-operator ash)
295                       (car (acode-operands w)) form2
296                       (cadr (acode-operands w)) (make-acode (%nx1-operator fixnum) shift-count)
297                       (acode.asserted-type w) nil)
298                 (rewrite-acode-form w))
299                ((and c2 (> c2 0) (< c2 (ash 1 24)) (eql (logcount c2) 1)
300                      (acode-form-typep form1 'integer trust-decls))
301                 (setq shift-count (1- (integer-length c2)))
302                 (setf (acode-operator w) (%nx1-operator ash)
303                       (cadr (acode-operands w)) (make-acode (%nx1-operator fixnum) shift-count)
304                       (acode.asserted-type w) nil)
305                 (rewrite-acode-form w))
306                (t
307                 (let* ((newtype nil)
308                        (newop (cond ((and (subtypep t1 'double-float)
309                                           (subtypep t2 'double-float))
310                                      (setq newtype 'double-float)
311                                      (%nx1-operator %double-float*-2))
312                                     ((and (subtypep t1 'single-float)
313                                           (subtypep t2 'single-float))
314                                      (setq newtype 'single-float)
315                                      (%nx1-operator %short-float*-2))
316                                     ((let* ((multype (bounded-integer-type-for-multiplication t1 t2))
317                                             (target-fixnum-type *nx-target-fixnum-type*))
318                                        (and multype (subtypep (setq newtype
319                                                                     (ctype-specifier multype))
320                                                               target-fixnum-type)
321                                             (subtypep t1 target-fixnum-type)
322                                             (subtypep t2 target-fixnum-type)))
323                                      (%nx1-operator %i*)))))
324                   (when newop
325                     (setf (acode.asserted-type w) newtype
326                           (acode-operator w) newop)))))))))
327
328
329(def-acode-rewrite acode-rewrite-div2 div2 asserted-type (&whole w form1 form2)
330  (let* ((trust-decls *acode-rewrite-trust-declarations*))
331    (acode-rewrite-binop-for-numeric-contagion form1 form2 trust-decls)
332    (or (acode-constant-fold-numeric-binop w form1 form2 '/)
333        (acode-strength-reduce-binop w form1 form2 'double-float (%nx1-operator div2) (%nx1-operator %double-float/-2))
334        (acode-strength-reduce-binop w form1 form2 'single-float (%nx1-operator div2) (%nx1-operator %short-float/-2))
335        (let* ((f2 (acode-fixnum-form-p form2))
336               (unwrapped (acode-unwrapped-form form1))
337               (f1 nil)
338               (f1/f2 nil))
339          (if (and f2
340                   (not (zerop f2))
341                   (acode-p unwrapped)
342                   (or (eq (acode-operator unwrapped) (%nx1-operator mul2))
343                       (eq (acode-operator unwrapped) (%nx1-operator %i*)))
344                   (setq f1 (acode-fixnum-form-p (car (acode-operands unwrapped))))
345                   (typep (setq f1/f2 (/ f1 f2)) 'fixnum))
346                (progn
347                  (break "here")
348                  (setf (acode-operator w) (%nx1-operator mul2)
349                        (acode-operands w) (list (make-acode (%nx1-operator fixnum) f1/f2)
350                                                 (cadr (acode-operands unwrapped)))
351                        (acode.asserted-type w) nil)
352                  (rewrite-acode-form w)
353                  t))))))
354
355(def-acode-rewrite acode-rewrite-minus1 minus1 asserted-type (&whole w form)
356  (rewrite-acode-form form)
357  (let* ((trust-decls *acode-rewrite-trust-declarations*)
358         (type (acode-form-type form trust-decls)))
359    (multiple-value-bind (val constp) (acode-constant-p form)
360      (cond ((and constp (ignore-errors (setq val (- val))))
361             (acode-rewrite-as-constant-ref w val))
362            ((subtypep type 'double-float)
363             (setf (acode-operator w) (%nx1-operator %double-float-negate)
364                   (acode.asserted-type w) 'double-float))
365            ((subtypep type 'single-float)
366             (setf (acode-operator w) (%nx1-operator %single-float-negate)
367                   (acode.asserted-type w) 'single-float))
368            (t (let* ((target-fixnum-type *nx-target-fixnum-type*))
369                 (when (subtypep type target-fixnum-type)
370                   (let* ((result-type (bounded-integer-type-for-subtraction '(integer 0 0) type)))
371                     (setf (acode-operator w)
372                           (if (or
373                                (and result-type
374                                     (subtypep (type-specifier result-type)
375                                               target-fixnum-type))
376                                (subtypep (or asserted-type '*)
377                                          target-fixnum-type)) 
378                             (%nx1-operator %%ineg)
379                             (%nx1-operator %ineg))
380                           (acode.asserted-type w)
381                           (or (ctype-specifier result-type) 'integer))))))))))
382
383(def-acode-rewrite acode-rewrite-realpart realpart asserted-type (&whole w arg) 
384  (let* ((trust-decls *acode-rewrite-trust-declarations*))
385    (rewrite-acode-form arg)
386    (cond ((acode-form-typep arg '(complex single-float) trust-decls)
387           (setf (acode-operator w) (%nx1-operator %complex-single-float-realpart)
388                 (acode.asserted-type w) 'single-float))
389          ((acode-form-typep arg '(complex double-float) trust-decls)
390           (setf (acode-operator w) (%nx1-operator %complex-double-float-realpart)
391                 (acode.asserted-type w) 'double-float)))))
392
393(def-acode-rewrite acode-rewrite-imagpart imagpart asserted-type (&whole w arg) 
394  (let* ((trust-decls *acode-rewrite-trust-declarations*))
395    (rewrite-acode-form arg)
396    (cond ((acode-form-typep arg '(complex single-float) trust-decls)
397           (setf (acode-operator w) (%nx1-operator %complex-single-float-imagpart)
398                 (acode.asserted-type w) 'single-float))
399          ((acode-form-typep arg '(complex double-float) trust-decls)
400           (setf (acode-operator w) (%nx1-operator %complex-double-float-imagpart)
401                 (acode.asserted-type w) 'double-float)))))
402
403(def-acode-rewrite acode-rewrite-complex complex asserted-type (&whole w r i)
404  (let* ((trust-decls *acode-rewrite-trust-declarations*))
405    (rewrite-acode-form r)
406    (rewrite-acode-form i)
407    (cond ((and (acode-form-typep r 'single-float trust-decls)
408                (acode-form-typep i 'single-float trust-decls))
409           (setf (acode-operator w) (%nx1-operator %make-complex-single-float)
410                 (acode.asserted-type w) '(complex single-float)))
411          ((and (acode-form-typep r 'double-float trust-decls)
412                (acode-form-typep i 'double-float trust-decls))
413           (setf (acode-operator w) (%nx1-operator %make-complex-double-float)
414                 (acode.asserted-type w) '(complex double-float))))))
415
416         
417
418         
419   
420 
421
422(def-acode-rewrite acode-rewrite-lambda lambda-list asserted-type  (&whole whole req opt rest keys auxen body p2-decls &optional code-note)
423  (declare (ignore code-note req rest))
424  (with-acode-declarations p2-decls
425    (dolist (optinit (cadr opt))
426      (rewrite-acode-form optinit))
427    (dolist (keyinit (nth 3 keys))
428      (rewrite-acode-form keyinit))
429    (do* ((auxvars (car auxen) (cdr auxvars))
430          (auxvals (cadr auxen) (cdr auxvals)))
431         ((null auxvars))
432      (acode-maybe-punt-var (car auxvars) (car auxvals)))
433    (rewrite-acode-form body)
434    ))
435
436(def-acode-rewrite acode-rewrite-let (let* let) asserted-type (&whole w vars vals body p2decls)
437  (collect ((new-vars)
438            (new-vals))
439    (dolist (var vars)
440      (let* ((val (pop vals))
441             (bits (nx-var-bits var)))
442        (declare (fixnum bits))
443        (unless (and (logbitp $vbitpunted bits)
444                     (not (logbitp $vbitspecial bits)))
445          (cond ((logbitp $vbitpuntable bits)
446                 (nx-set-var-bits var (logior (ash 1 $vbitpunted) bits))
447                 (rewrite-acode-form val)
448                 (nx2-replace-var-refs var val)
449                 (setf (var-ea var) val))
450                (t
451                 (rewrite-acode-form val)
452                 (new-vars var)
453                 (new-vals val))))))
454    (setf (car (acode-operands w)) (new-vars)
455          (cadr (acode-operands w)) (new-vals))
456    (with-acode-declarations p2decls (rewrite-acode-form body asserted-type))))
457   
458     
459(def-acode-rewrite acode-rewrite-progn progn asserted-type (forms)
460  (do* ()
461       ((null forms))
462    (let* ((form (pop forms)))
463      (if forms
464        (rewrite-acode-form form)
465        (rewrite-acode-form form asserted-type)))))
466
467(def-acode-rewrite acode-rewrite-prog1 (prog1 multiple-value-prog1) asserted-type  (&whole w (first &rest others))
468  (rewrite-acode-form first asserted-type)
469  (dolist (other others) (rewrite-acode-form other)))
470
471
472(def-acode-rewrite acode-rewrite-svref svref asserted-type (&whole w vector idx)
473  (rewrite-acode-form vector)
474  (rewrite-acode-form idx )
475  (let* ((cv (acode-constant-p vector)))
476    (when (and (typep cv 'simple-vector)
477               (eql (acode-operator w) (%nx1-operator svref)))
478      (let* ((cidx (acode-fixnum-form-p idx)))
479        (when (and (typep cidx 'fixnum)
480                   (>= (the fixnum cidx) 0)
481                   (< (the fixnum cidx) (the fixnum (uvsize cv))))
482          (let* ((val (%svref cv cidx)))
483            (case val
484              (nil (setf (acode-operator w) (%nx1-operator nil)
485                         (acode-operands w) nil))
486              ((t) (setf (acode-operator w) (%nx1-operator t)
487                         (acode-operands w) nil))
488              (t
489               (setf (acode-operator w) (if (nx1-target-fixnump val)
490                                          (%nx1-operator fixnum)
491                                          (%nx1-operator immediate))
492                     (acode-operands w) (cons val nil))))
493            (setf (acode.asserted-type w) nil)
494            t))))))
495
496(def-acode-rewrite acode-rewrite-%svref %svref asserted-type (vector i)
497  (rewrite-acode-form vector)
498  (rewrite-acode-form i))
499
500
501(def-acode-rewrite acode-rewrite-%sbchar %sbchar  asserted-type (&whole w string idx)
502  (rewrite-acode-form string)
503  (rewrite-acode-form idx)
504  (let* ((cv (acode-constant-p string)))
505    (when (typep cv 'simple-string)
506      (let* ((cidx (acode-fixnum-form-p idx)))
507        (when (and (typep cidx 'fixnum)
508                   (>= (the fixnum cidx) 0)
509                   (< (the fixnum cidx) (the fixnum (length cv))))
510          (let* ((val (%schar cv cidx)))
511            (setf (acode-operator w) (%nx1-operator immediate)
512                  (car (acode-operands w)) val
513                  (cdr (acode-operands w)) nil
514                  (acode.asserted-type w) nil)
515            t))))))
516
517
518(def-acode-rewrite acode-rewrite-consp consp asserted-type (&whole w cc thing)
519  (rewrite-acode-form thing)
520  (multiple-value-bind (cthing constantp) (acode-constant-p thing)
521    (if constantp
522      (let* ((consp (consp cthing))
523             (ccode (car (acode-operands cc)))
524             (val (if (eq ccode :eq) (not (not consp)) (not consp))))
525        (setf (acode-operator w) (if val (%nx1-operator t) (%nx1-operator nil))
526              (acode-operands w) nil
527              (acode.asserted-type w) nil)))))
528
529
530(def-acode-rewrite acode-rewrite-cxr (%car %cdr car cdr) asserted-type (&whole w cell)
531  (rewrite-acode-form cell)
532  (multiple-value-bind (val constantp) (acode-constant-p cell)
533    (when (and constantp (typep val 'list) (not (and *load-time-eval-token* (eq (car val) *load-time-eval-token*))))
534      (let* ((op (acode-operator w)))
535        (acode-rewrite-as-constant-ref w (if (or (eql op (%nx1-operator car))
536                                                 (eql op (%nx1-operator %car)))
537                                           (car val)
538                                           (cdr val)))))))
539
540
541
542                   
543(def-acode-rewrite acode-rewrite-%gvector %gvector asserted-type  (&whole w arglist)
544  (let* ((all-args (append (car arglist) (reverse (cadr arglist)))))
545    (dolist (arg all-args)
546      (rewrite-acode-form arg))
547    ;; Could try to map constant subtag to type here
548    ))
549
550(def-acode-rewrite acode-rewrite-char-code (%char-code char-code) asserted-type  (&whole w c)
551  (rewrite-acode-form c)
552  (let* ((char (acode-constant-p c)))
553    (when (typep char 'character)
554      (let* ((code (char-code char)))
555        (setf (acode-operator w) (%nx1-operator fixnum)
556              (acode-operands w) (list code)
557              (acode.asserted-type w) nil)))))
558
559(def-acode-rewrite acode-rewrite-logior (logior2 %ilogior2 %natural-logior) asserted-type  (&whole w x y) 
560  (or (acode-constant-fold-numeric-binop  w x y 'logior)
561      (acode-strength-reduce-binop w x y *nx-target-fixnum-type* (%nx1-operator logior2) (%nx1-operator %ilogior2))
562      (acode-strength-reduce-binop w x y *nx-target-natural-type* (%nx1-operator logior2) (%nx1-operator %natural-logior)))
563)
564
565(def-acode-rewrite acode-rewrite-logand (logand2 %ilogand2 %natural-logand) asserted-type  (&whole w x y) 
566  (or (acode-constant-fold-numeric-binop  w x y 'logand)
567      (acode-strength-reduce-binop w x y *nx-target-fixnum-type* (%nx1-operator logand2) (%nx1-operator %ilogand2))
568      (acode-strength-reduce-binop w x y *nx-target-natural-type* (%nx1-operator logand2) (%nx1-operator %natural-logand))
569      (cond ((eql -1 (acode-fixnum-form-p x))
570             (setf (acode-operator w) (%nx1-operator require-integer)
571                   (acode-operands w) (list y)
572                   (acode.asserted-type w) nil)
573             t)
574            ((eql -1 (acode-fixnum-form-p y))
575             (setf (acode-operator w) (%nx1-operator require-integer)
576                   (acode-operands w) (list x)
577                   (acode.asserted-type w) nil)
578             t))))
579
580(def-acode-rewrite acode-rewrite-logxor (logxor2 %ilogxor2 %natural-logxor) asserted-type  (&whole w x y) 
581  (or (acode-constant-fold-numeric-binop  w x y 'logxor)
582      (acode-strength-reduce-binop w x y *nx-target-fixnum-type* (%nx1-operator logxor2) (%nx1-operator %ilogxor2))
583      (acode-strength-reduce-binop w x y *nx-target-natural-type* (%nx1-operator logxor2) (%nx1-operator %natural-logxor))))
584                                   
585
586   
587(def-acode-rewrite acode-rewrite-%ineg %ineg asserted-type (&whole w x)
588  (rewrite-acode-form x)
589  (let* ((val (acode-fixnum-form-p x))
590         (negated (if val (- val))))
591    (if negated
592      (setf (acode-operator w) (if (typep negated *nx-target-fixnum-type*)
593                                 (%nx1-operator fixnum)
594                                 (%nx1-operator immediate))
595            (acode-operands w) (list negated)
596            (acode.asserted-type w) nil))))
597
598(def-acode-rewrite rewrite-type-asserted-form type-asserted-form asserted-type (&whole w type form &optional check)
599  (declare (ignore check))
600  (rewrite-acode-form form type))
601
602(def-acode-rewrite rewrite-typed-form typed-form asserted-type (&whole w type form &optional check)
603  (rewrite-acode-form form (if (or check *acode-rewrite-trust-declarations*) type t)))
604
605(def-acode-rewrite rewrite-trivial-unary (fixnum immediate simple-function closed-function lexical-reference bound-special-ref special-ref local-go %function global-ref free-reference inherited-arg) asserted-type (&whole w val)
606  (declare (ignore val)))
607
608
609(def-acode-rewrite rewrite-nullary (t nil %unbound-marker %slot-unbound-marker %illegal-marker %current-tcr %foreign-stack-pointer %current-frame-ptr %interrupt-poll) asserted-type (&whole w))
610
611(def-acode-rewrite rewrite-call (call lexical-function-call builtin-call) asserted-type (&whole w callable arglist &optional spread-p)
612  (declare (ignore spread-p))
613  (when (acode-p callable)
614    (rewrite-acode-form callable))
615  (dolist (arg (car arglist))
616    (rewrite-acode-form arg))
617  (dolist (arg (cadr arglist))
618    (rewrite-acode-form arg)))
619
620
621(def-acode-rewrite acode-rewrite-arglist-form (list* %err-disp) asserted-type (&whole w arglist)
622  (dolist (arg (car arglist))
623    (rewrite-acode-form arg))
624  (dolist (arg (cadr arglist))
625    (rewrite-acode-form arg)))
626
627(def-acode-rewrite acode-rewrite-self-call self-call asserted-type (arglist &optional spread-p)
628  (declare (ignore spread-p))
629  (dolist (arg (car arglist))
630    (rewrite-acode-form arg))
631  (dolist (arg (cadr arglist))
632    (rewrite-acode-form arg)))
633
634
635(def-acode-rewrite acode-rewrite-formlist (list values %temp-list vector) asserted-type (formlist)
636  (dolist (form formlist) (rewrite-acode-form form)))
637
638(def-acode-rewrite acode-rewrite-multiple-value-bind multiple-value-bind asserted-type (vars valform body p2decls)
639  (declare (ignore vars))
640  (rewrite-acode-form valform)
641  (with-acode-declarations p2decls (rewrite-acode-form body asserted-type)))
642
643
644(def-acode-rewrite acode-rewrite-local-tagbody local-tagbody asserted-type (tags forms)
645  (declare (ignore tags))
646  (dolist (form forms) (rewrite-acode-form form)))
647
648(def-acode-rewrite acode-rewrite-tag-label tag-label asserted-type (&rest ignore)
649  (declare (ignore ignore)))
650
651(def-acode-rewrite acode-rewrite-local-block local-block asserted-type (tag body)
652  (declare (ignore tag))
653  (rewrite-acode-form body asserted-type))
654
655
656(def-acode-rewrite acode-rewrite-local-return-from local-return-from asserted-type (block value)
657  (declare (ignore block))
658  (rewrite-acode-form value))
659
660(def-acode-rewrite acode-rewrite-or or asserted-type (forms)
661  (dolist (form forms) (rewrite-acode-form form))
662  (do* ((forms forms (cdr forms)))
663       ((null (cdr forms)))
664    (multiple-value-bind (val constantp) (acode-constant-p (car forms))
665      (when (and val constantp)
666        (setf (cdr forms) nil)))))
667
668
669(def-acode-rewrite acode-rewrite-labels-flet (labels flet)  asserted-type (vars funcs body p2decls)
670  (declare (ignore vars funcs))
671  (with-acode-declarations p2decls (rewrite-acode-form body asserted-type)))
672
673(def-acode-rewrite acode-rewrite-%decls-body %decls-body asserted-type (form p2decls)
674  (with-acode-declarations p2decls (rewrite-acode-form form asserted-type)))
675
676
677;;; The backends may try to eliminate the &rest arg if the body is
678;;; obviously an APPLY that uses it.  We could do that here.
679(def-acode-rewrite acode-rewrite-lambda-bind lambda-bind asserted-type (vals req rest keys-p auxen body p2decls)
680  (declare (ignore keys-p rest))
681  (dolist (var req)
682    (acode-maybe-punt-var var (pop vals)))
683  (dolist (val vals)
684    (rewrite-acode-form val))
685  (do* ((auxvars (car auxen) (cdr auxvars))
686        (auxvals (cadr auxen) (cdr auxvals)))
687       ((null auxvars))
688    (acode-maybe-punt-var (car auxvars) (car auxvals)))
689  (with-acode-declarations p2decls (rewrite-acode-form body asserted-type))
690)
691
692;;; The frontend may have type-constrained the value.  That should probably
693;;; happen here.
694(def-acode-rewrite acode-rewrite-setq-lexical setq-lexical asserted-type (var value)
695  (rewrite-acode-form value (or (and *acode-rewrite-trust-declarations*
696                                     (var-declared-type var))
697                                t)))
698
699(def-acode-rewrite acode-rewrite-unwind-protect unwind-protect asserted-type (protected-form cleanup-form)
700  (rewrite-acode-form protected-form asserted-type)
701  (rewrite-acode-form cleanup-form))
702
703(def-acode-rewrite acode-rewrite-setq-special (global-setq setq-special) asserted-type (sym val)
704  (declare (ignore sym))
705  (rewrite-acode-form val))
706
707(def-acode-rewrite acode-rewrite-immediate-get-xxx immediate-get-xxx asserted-type (bits ptr offset)
708  (declare (ignore bits))
709  (rewrite-acode-form ptr)
710  (rewrite-acode-form offset))
711
712(def-acode-rewrite with-variable-c-frame with-variable-c-frame asserted-type (size body)
713  (rewrite-acode-form size)
714  (rewrite-acode-form body asserted-type))
715
716(def-acode-rewrite acode-rewrite-ff-call (ff-call eabi-ff-call poweropen-ff-call i386-ff-call) asserted-type (address argspecs argvals resultspec &optional monitor)
717  (declare (ignore argspecs resultspec monitor))
718  (rewrite-acode-form address)
719  (dolist (val argvals) (rewrite-acode-form val)))
720
721(def-acode-rewrite acode-rewrite-%ilsl %ilsl asserted-type (&whole w count num)
722  (acode-constant-fold-numeric-binop  w count num '%ilsl))
723
724(def-acode-rewrite acode-rewrite-if if asserted-type (&whole w test true false)
725  (rewrite-acode-form test)
726  (rewrite-acode-form true asserted-type)
727  (rewrite-acode-form false asserted-type)
728  (multiple-value-bind (val constantp) (acode-constant-p test)
729    (when constantp
730      (let* ((form (if val true false)))
731        (setf (acode-operator w) (acode-operator form)
732              (acode-operands w) (acode-operands form)
733              (acode.asserted-type w) nil)))))
734
735
736(def-acode-rewrite acode-rewrite-%izerop %izerop asserted-type (&whole w cc form)
737  (rewrite-acode-form form)
738  (multiple-value-bind (val constantp) (acode-constant-p form)
739    (when constantp
740      (setf (acode-operator w)
741            (if (if (eq (car (acode-operands cc)) :eq) (eql val 0) (not (eql val 0)))
742                (%nx1-operator t)
743                (%nx1-operator nil))
744            (acode-operands w) nil
745            (acode.asserted-type w) nil))))
746
747(def-acode-rewrite acode-rewrite-eq eq asserted-type (&whole w cc x y)
748  (rewrite-acode-form x)
749  (rewrite-acode-form y)
750  (multiple-value-bind (xval xconst) (acode-constant-p x)
751    (multiple-value-bind (yval yconst) (acode-constant-p y)
752      (when (and xconst yconst)
753        (setf (acode-operator w)
754              (if (if (eq (car (acode-operands cc)) :eq) (eql xval yval) (not (eql xval yval)))
755                (%nx1-operator t)
756                (%nx1-operator nil))
757              (acode-operands w) nil
758              (acode.asserted-type w) nil)))))
759
760(def-acode-rewrite acode-rewrite-with-c-frame with-c-frame asserted-type (body)
761  (rewrite-acode-form body asserted-type))
762
763(def-acode-rewrite acode-rewrite-ash ash asserted-type (&whole w num amt)
764  (or (acode-constant-fold-numeric-binop w num amt 'ash)
765      (let* ((maxbits (target-word-size-case
766                       (32 29)
767                       (64 60)))
768             (cnum (acode-constant-p num))
769             (camt (acode-constant-p amt))
770             (trust-decls *acode-rewrite-trust-declarations*)
771             (fixnum-type *nx-target-fixnum-type*)
772             (natural-type *nx-target-natural-type*))
773        (cond ((eql camt 0) (setf (acode-operator w) (%nx1-operator require-integer)
774                                  (cdr (acode-operands w)) nil
775                                  (acode.asserted-type w) nil))
776              ((and (typep camt fixnum-type)
777                    (< camt 0))
778               (if (acode-form-typep num fixnum-type trust-decls)
779                 (setf (acode-operator w) (%nx1-operator %iasr)
780                       (acode-operands w) (list (make-acode (%nx1-operator fixnum)
781                                                            (- camt))
782                                                num)
783                       (acode.asserted-type w) nil)
784                 (if (acode-form-typep num natural-type trust-decls)
785                   (if (< (- camt) (arch::target-nbits-in-word
786                                    (backend-target-arch *target-backend*)))
787                     (setf (acode-operator w) (%nx1-operator natural-shift-right)
788                           (cadr (acode-operands w)) (make-acode (%nx1-operator fixnum) (- camt))
789                           (acode.asserted-type w) nil)
790
791                     (setf (acode-operator w) (%nx1-operator progn)
792                           (acode-operands w) (list (list (make-acode (%nx1-operator require-integer) num)
793                                                          (make-acode (%nx1-operator fixnum) 0)))
794                           (acode.asserted-type w) nil)))))
795              ((and (typep camt 'fixnum)
796                    (<= 0 camt maxbits)
797                    (or (acode-form-typep num `(signed-byte ,(- (1+ maxbits) camt)) trust-decls)
798                        (and (acode-form-typep num fixnum-type trust-decls)
799                             (subtypep asserted-type fixnum-type))))
800               (setf (acode-operator w) (%nx1-operator %ilsl)
801                     (acode-operands w) (list amt num)
802                     (acode.asserted-type w) nil))
803              ((and (typep camt 'fixnum)
804                    (< 0 camt (arch::target-nbits-in-word
805                               (backend-target-arch *target-backend*)))
806                    (acode-form-typep num natural-type trust-decls)
807                    (subtypep asserted-type natural-type))
808               (setf (acode-operator w) (%nx1-operator natural-shift-left)
809                     (acode.asserted-type w) nil))
810              ((typep cnum 'fixnum)
811               (let* ((field-width (1+ (integer-length cnum)))
812                      ;; num fits in a `(signed-byte ,field-width)
813                      (max-shift (- (1+ maxbits) field-width)))
814                 (if (and (>= max-shift 0)
815                          (acode-form-typep amt `(mod ,(1+ max-shift)) trust-decls))
816                   (setf (acode-operator w) (%nx1-operator %ilsl)
817                         (acode-operands w) (list amt num)
818                         (acode.asserted-type w) nil))))
819              ((or (and (subtypep asserted-type fixnum-type)
820                        (acode-form-typep num fixnum-type trust-decls)
821                        (target-word-size-case
822                         (32 (acode-form-typep amt '(signed-byte 5) trust-decls))
823                         (64 (acode-form-typep amt '(signed-byte 6) trust-decls))))
824                   (let* ((numtype (specifier-type (acode-form-type num trust-decls)))
825                          (amttype (specifier-type (acode-form-type amt trust-decls)))
826                          (fixtype (specifier-type fixnum-type)))
827                     (if (and (typep numtype 'numeric-ctype)
828                              (csubtypep numtype fixtype)
829                              (typep amttype 'numeric-ctype)
830                              (csubtypep amttype fixtype))
831                       (let* ((highnum (numeric-ctype-high numtype))
832                              (lownum (numeric-ctype-low numtype))
833                              (widenum (if (> (integer-length highnum)
834                                              (integer-length lownum))
835                                         highnum
836                                         lownum))
837                              (maxleft (numeric-ctype-high amttype)))
838                         
839                         (and (>= (numeric-ctype-low amttype)
840                                        (target-word-size-case
841                                         (32 -31)
842                                         (64 -63)))
843                                    (< maxleft
844                                       (arch::target-nbits-in-word (backend-target-arch *target-backend*)))
845                                    (typep (ignore-errors (ash widenum maxleft))
846                                           fixnum-type))))))
847               (setf (acode-operator w) (%nx1-operator fixnum-ash)
848                     (acode.asserted-type w) nil))))))
849
850(def-acode-rewrite acode-rewrite-multiple-value-call multiple-value-call asserted-type (callable formlist)
851  (when (acode-p callable)
852    (rewrite-acode-form callable))
853  (dolist (form formlist) (rewrite-acode-form form)))
854
855(def-acode-rewrite acode-rewrite-numcmp numcmp asserted-type (&whole w cc num1 num2)
856  (let* ((ccval (car (acode-operands cc)))
857         (fn (case ccval
858               (:lt '<)
859               (:le '<=)
860               (:eq '=)
861               (:ne '/=)
862               (:ge '>=)
863               (:gt '>))))
864    ;;(acode-rewrite-binop-for-numeric-contagion num1 num2 *acode-rewrite-trust-declarations*)
865    (multiple-value-bind (v1 c1) (acode-constant-p num1)
866      (multiple-value-bind (v2 c2) (acode-constant-p num2)
867        (multiple-value-bind (constval error)
868            (if (and c1 c2)
869              (ignore-errors (funcall fn v1 v2))
870              (values nil t))
871          (if (not error)
872            (acode-rewrite-as-constant-ref w constval)
873            (let* ((op (acode-operator w)))
874              (or (acode-strength-reduce-binop w num1 num2 *nx-target-fixnum-type* op (%nx1-operator %i<>))
875                  (acode-strength-reduce-binop w num1 num2 *nx-target-natural-type* op (%nx1-operator %natural<>))
876                  (acode-strength-reduce-binop w num1 num2 'double-float op (%nx1-operator double-float-compare))
877                  (acode-strength-reduce-binop w num1 num2 'single-float op (%nx1-operator short-float-compare))
878                  ;; Could try contagion here
879                  ))))))))
Note: See TracBrowser for help on using the repository browser.