source: release/1.10/source/compiler/acode-rewrite.lisp @ 16174

Last change on this file since 16174 was 16174, checked in by rme, 5 years ago

acode-rewrite-div2 fix from trunk.

File size: 42.7 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                  (setf (acode-operator w) (%nx1-operator mul2)
348                        (acode-operands w) (list (make-acode (%nx1-operator fixnum) f1/f2)
349                                                 (cadr (acode-operands unwrapped)))
350                        (acode.asserted-type w) nil)
351                  (rewrite-acode-form w)
352                  t))))))
353
354(def-acode-rewrite acode-rewrite-minus1 minus1 asserted-type (&whole w form)
355  (rewrite-acode-form form)
356  (let* ((trust-decls *acode-rewrite-trust-declarations*)
357         (type (acode-form-type form trust-decls)))
358    (multiple-value-bind (val constp) (acode-constant-p form)
359      (cond ((and constp (ignore-errors (setq val (- val))))
360             (acode-rewrite-as-constant-ref w val))
361            ((subtypep type 'double-float)
362             (setf (acode-operator w) (%nx1-operator %double-float-negate)
363                   (acode.asserted-type w) 'double-float))
364            ((subtypep type 'single-float)
365             (setf (acode-operator w) (%nx1-operator %single-float-negate)
366                   (acode.asserted-type w) 'single-float))
367            (t (let* ((target-fixnum-type *nx-target-fixnum-type*))
368                 (when (subtypep type target-fixnum-type)
369                   (let* ((result-type (bounded-integer-type-for-subtraction '(integer 0 0) type)))
370                     (setf (acode-operator w)
371                           (if (or
372                                (and result-type
373                                     (subtypep (type-specifier result-type)
374                                               target-fixnum-type))
375                                (subtypep (or asserted-type '*)
376                                          target-fixnum-type)) 
377                             (%nx1-operator %%ineg)
378                             (%nx1-operator %ineg))
379                           (acode.asserted-type w)
380                           (or (ctype-specifier result-type) 'integer))))))))))
381
382(def-acode-rewrite acode-rewrite-realpart realpart asserted-type (&whole w arg) 
383  (let* ((trust-decls *acode-rewrite-trust-declarations*))
384    (rewrite-acode-form arg)
385    (cond ((acode-form-typep arg '(complex single-float) trust-decls)
386           (setf (acode-operator w) (%nx1-operator %complex-single-float-realpart)
387                 (acode.asserted-type w) 'single-float))
388          ((acode-form-typep arg '(complex double-float) trust-decls)
389           (setf (acode-operator w) (%nx1-operator %complex-double-float-realpart)
390                 (acode.asserted-type w) 'double-float)))))
391
392(def-acode-rewrite acode-rewrite-imagpart imagpart asserted-type (&whole w arg) 
393  (let* ((trust-decls *acode-rewrite-trust-declarations*))
394    (rewrite-acode-form arg)
395    (cond ((acode-form-typep arg '(complex single-float) trust-decls)
396           (setf (acode-operator w) (%nx1-operator %complex-single-float-imagpart)
397                 (acode.asserted-type w) 'single-float))
398          ((acode-form-typep arg '(complex double-float) trust-decls)
399           (setf (acode-operator w) (%nx1-operator %complex-double-float-imagpart)
400                 (acode.asserted-type w) 'double-float)))))
401
402(def-acode-rewrite acode-rewrite-complex complex asserted-type (&whole w r i)
403  (let* ((trust-decls *acode-rewrite-trust-declarations*))
404    (rewrite-acode-form r)
405    (rewrite-acode-form i)
406    (cond ((and (acode-form-typep r 'single-float trust-decls)
407                (acode-form-typep i 'single-float trust-decls))
408           (setf (acode-operator w) (%nx1-operator %make-complex-single-float)
409                 (acode.asserted-type w) '(complex single-float)))
410          ((and (acode-form-typep r 'double-float trust-decls)
411                (acode-form-typep i 'double-float trust-decls))
412           (setf (acode-operator w) (%nx1-operator %make-complex-double-float)
413                 (acode.asserted-type w) '(complex double-float))))))
414
415         
416
417         
418   
419 
420
421(def-acode-rewrite acode-rewrite-lambda lambda-list asserted-type  (&whole whole req opt rest keys auxen body p2-decls &optional code-note)
422  (declare (ignore code-note req rest))
423  (with-acode-declarations p2-decls
424    (dolist (optinit (cadr opt))
425      (rewrite-acode-form optinit))
426    (dolist (keyinit (nth 3 keys))
427      (rewrite-acode-form keyinit))
428    (do* ((auxvars (car auxen) (cdr auxvars))
429          (auxvals (cadr auxen) (cdr auxvals)))
430         ((null auxvars))
431      (acode-maybe-punt-var (car auxvars) (car auxvals)))
432    (rewrite-acode-form body)
433    ))
434
435(def-acode-rewrite acode-rewrite-let (let* let) asserted-type (&whole w vars vals body p2decls)
436  (collect ((new-vars)
437            (new-vals))
438    (dolist (var vars)
439      (let* ((val (pop vals))
440             (bits (nx-var-bits var)))
441        (declare (fixnum bits))
442        (unless (and (logbitp $vbitpunted bits)
443                     (not (logbitp $vbitspecial bits)))
444          (cond ((logbitp $vbitpuntable bits)
445                 (nx-set-var-bits var (logior (ash 1 $vbitpunted) bits))
446                 (rewrite-acode-form val)
447                 (nx2-replace-var-refs var val)
448                 (setf (var-ea var) val))
449                (t
450                 (rewrite-acode-form val)
451                 (new-vars var)
452                 (new-vals val))))))
453    (setf (car (acode-operands w)) (new-vars)
454          (cadr (acode-operands w)) (new-vals))
455    (with-acode-declarations p2decls (rewrite-acode-form body asserted-type))))
456   
457     
458(def-acode-rewrite acode-rewrite-progn progn asserted-type (forms)
459  (do* ()
460       ((null forms))
461    (let* ((form (pop forms)))
462      (if forms
463        (rewrite-acode-form form)
464        (rewrite-acode-form form asserted-type)))))
465
466(def-acode-rewrite acode-rewrite-prog1 (prog1 multiple-value-prog1) asserted-type  (&whole w (first &rest others))
467  (rewrite-acode-form first asserted-type)
468  (dolist (other others) (rewrite-acode-form other)))
469
470
471(def-acode-rewrite acode-rewrite-svref svref asserted-type (&whole w vector idx)
472  (rewrite-acode-form vector)
473  (rewrite-acode-form idx )
474  (let* ((cv (acode-constant-p vector)))
475    (when (and (typep cv 'simple-vector)
476               (eql (acode-operator w) (%nx1-operator svref)))
477      (let* ((cidx (acode-fixnum-form-p idx)))
478        (when (and (typep cidx 'fixnum)
479                   (>= (the fixnum cidx) 0)
480                   (< (the fixnum cidx) (the fixnum (uvsize cv))))
481          (let* ((val (%svref cv cidx)))
482            (case val
483              (nil (setf (acode-operator w) (%nx1-operator nil)
484                         (acode-operands w) nil))
485              ((t) (setf (acode-operator w) (%nx1-operator t)
486                         (acode-operands w) nil))
487              (t
488               (setf (acode-operator w) (if (nx1-target-fixnump val)
489                                          (%nx1-operator fixnum)
490                                          (%nx1-operator immediate))
491                     (acode-operands w) (cons val nil))))
492            (setf (acode.asserted-type w) nil)
493            t))))))
494
495(def-acode-rewrite acode-rewrite-%svref %svref asserted-type (vector i)
496  (rewrite-acode-form vector)
497  (rewrite-acode-form i))
498
499
500(def-acode-rewrite acode-rewrite-%sbchar %sbchar  asserted-type (&whole w string idx)
501  (rewrite-acode-form string)
502  (rewrite-acode-form idx)
503  (let* ((cv (acode-constant-p string)))
504    (when (typep cv 'simple-string)
505      (let* ((cidx (acode-fixnum-form-p idx)))
506        (when (and (typep cidx 'fixnum)
507                   (>= (the fixnum cidx) 0)
508                   (< (the fixnum cidx) (the fixnum (length cv))))
509          (let* ((val (%schar cv cidx)))
510            (setf (acode-operator w) (%nx1-operator immediate)
511                  (car (acode-operands w)) val
512                  (cdr (acode-operands w)) nil
513                  (acode.asserted-type w) nil)
514            t))))))
515
516
517(def-acode-rewrite acode-rewrite-consp consp asserted-type (&whole w cc thing)
518  (rewrite-acode-form thing)
519  (multiple-value-bind (cthing constantp) (acode-constant-p thing)
520    (if constantp
521      (let* ((consp (consp cthing))
522             (ccode (car (acode-operands cc)))
523             (val (if (eq ccode :eq) (not (not consp)) (not consp))))
524        (setf (acode-operator w) (if val (%nx1-operator t) (%nx1-operator nil))
525              (acode-operands w) nil
526              (acode.asserted-type w) nil)))))
527
528
529(def-acode-rewrite acode-rewrite-cxr (%car %cdr car cdr) asserted-type (&whole w cell)
530  (rewrite-acode-form cell)
531  (multiple-value-bind (val constantp) (acode-constant-p cell)
532    (when (and constantp (typep val 'list) (not (and *load-time-eval-token* (eq (car val) *load-time-eval-token*))))
533      (let* ((op (acode-operator w)))
534        (acode-rewrite-as-constant-ref w (if (or (eql op (%nx1-operator car))
535                                                 (eql op (%nx1-operator %car)))
536                                           (car val)
537                                           (cdr val)))))))
538
539
540
541                   
542(def-acode-rewrite acode-rewrite-%gvector %gvector asserted-type  (&whole w arglist)
543  (let* ((all-args (append (car arglist) (reverse (cadr arglist)))))
544    (dolist (arg all-args)
545      (rewrite-acode-form arg))
546    ;; Could try to map constant subtag to type here
547    ))
548
549(def-acode-rewrite acode-rewrite-char-code (%char-code char-code) asserted-type  (&whole w c)
550  (rewrite-acode-form c)
551  (let* ((char (acode-constant-p c)))
552    (when (typep char 'character)
553      (let* ((code (char-code char)))
554        (setf (acode-operator w) (%nx1-operator fixnum)
555              (acode-operands w) (list code)
556              (acode.asserted-type w) nil)))))
557
558(def-acode-rewrite acode-rewrite-logior (logior2 %ilogior2 %natural-logior) asserted-type  (&whole w x y) 
559  (or (acode-constant-fold-numeric-binop  w x y 'logior)
560      (acode-strength-reduce-binop w x y *nx-target-fixnum-type* (%nx1-operator logior2) (%nx1-operator %ilogior2))
561      (acode-strength-reduce-binop w x y *nx-target-natural-type* (%nx1-operator logior2) (%nx1-operator %natural-logior)))
562)
563
564(def-acode-rewrite acode-rewrite-logand (logand2 %ilogand2 %natural-logand) asserted-type  (&whole w x y) 
565  (or (acode-constant-fold-numeric-binop  w x y 'logand)
566      (acode-strength-reduce-binop w x y *nx-target-fixnum-type* (%nx1-operator logand2) (%nx1-operator %ilogand2))
567      (acode-strength-reduce-binop w x y *nx-target-natural-type* (%nx1-operator logand2) (%nx1-operator %natural-logand))
568      (cond ((eql -1 (acode-fixnum-form-p x))
569             (setf (acode-operator w) (%nx1-operator require-integer)
570                   (acode-operands w) (list y)
571                   (acode.asserted-type w) nil)
572             t)
573            ((eql -1 (acode-fixnum-form-p y))
574             (setf (acode-operator w) (%nx1-operator require-integer)
575                   (acode-operands w) (list x)
576                   (acode.asserted-type w) nil)
577             t))))
578
579(def-acode-rewrite acode-rewrite-logxor (logxor2 %ilogxor2 %natural-logxor) asserted-type  (&whole w x y) 
580  (or (acode-constant-fold-numeric-binop  w x y 'logxor)
581      (acode-strength-reduce-binop w x y *nx-target-fixnum-type* (%nx1-operator logxor2) (%nx1-operator %ilogxor2))
582      (acode-strength-reduce-binop w x y *nx-target-natural-type* (%nx1-operator logxor2) (%nx1-operator %natural-logxor))))
583                                   
584
585   
586(def-acode-rewrite acode-rewrite-%ineg %ineg asserted-type (&whole w x)
587  (rewrite-acode-form x)
588  (let* ((val (acode-fixnum-form-p x))
589         (negated (if val (- val))))
590    (if negated
591      (setf (acode-operator w) (if (typep negated *nx-target-fixnum-type*)
592                                 (%nx1-operator fixnum)
593                                 (%nx1-operator immediate))
594            (acode-operands w) (list negated)
595            (acode.asserted-type w) nil))))
596
597(def-acode-rewrite rewrite-type-asserted-form type-asserted-form asserted-type (&whole w type form &optional check)
598  (declare (ignore check))
599  (rewrite-acode-form form type))
600
601(def-acode-rewrite rewrite-typed-form typed-form asserted-type (&whole w type form &optional check)
602  (rewrite-acode-form form (if (or check *acode-rewrite-trust-declarations*) type t)))
603
604(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)
605  (declare (ignore val)))
606
607
608(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))
609
610(def-acode-rewrite rewrite-call (call lexical-function-call builtin-call) asserted-type (&whole w callable arglist &optional spread-p)
611  (declare (ignore spread-p))
612  (when (acode-p callable)
613    (rewrite-acode-form callable))
614  (dolist (arg (car arglist))
615    (rewrite-acode-form arg))
616  (dolist (arg (cadr arglist))
617    (rewrite-acode-form arg)))
618
619
620(def-acode-rewrite acode-rewrite-arglist-form (list* %err-disp) asserted-type (&whole w arglist)
621  (dolist (arg (car arglist))
622    (rewrite-acode-form arg))
623  (dolist (arg (cadr arglist))
624    (rewrite-acode-form arg)))
625
626(def-acode-rewrite acode-rewrite-self-call self-call asserted-type (arglist &optional spread-p)
627  (declare (ignore spread-p))
628  (dolist (arg (car arglist))
629    (rewrite-acode-form arg))
630  (dolist (arg (cadr arglist))
631    (rewrite-acode-form arg)))
632
633
634(def-acode-rewrite acode-rewrite-formlist (list values %temp-list vector) asserted-type (formlist)
635  (dolist (form formlist) (rewrite-acode-form form)))
636
637(def-acode-rewrite acode-rewrite-multiple-value-bind multiple-value-bind asserted-type (vars valform body p2decls)
638  (declare (ignore vars))
639  (rewrite-acode-form valform)
640  (with-acode-declarations p2decls (rewrite-acode-form body asserted-type)))
641
642
643(def-acode-rewrite acode-rewrite-local-tagbody local-tagbody asserted-type (tags forms)
644  (declare (ignore tags))
645  (dolist (form forms) (rewrite-acode-form form)))
646
647(def-acode-rewrite acode-rewrite-tag-label tag-label asserted-type (&rest ignore)
648  (declare (ignore ignore)))
649
650(def-acode-rewrite acode-rewrite-local-block local-block asserted-type (tag body)
651  (declare (ignore tag))
652  (rewrite-acode-form body asserted-type))
653
654
655(def-acode-rewrite acode-rewrite-local-return-from local-return-from asserted-type (block value)
656  (declare (ignore block))
657  (rewrite-acode-form value))
658
659(def-acode-rewrite acode-rewrite-or or asserted-type (forms)
660  (dolist (form forms) (rewrite-acode-form form))
661  (do* ((forms forms (cdr forms)))
662       ((null (cdr forms)))
663    (multiple-value-bind (val constantp) (acode-constant-p (car forms))
664      (when (and val constantp)
665        (setf (cdr forms) nil)))))
666
667
668(def-acode-rewrite acode-rewrite-labels-flet (labels flet)  asserted-type (vars funcs body p2decls)
669  (declare (ignore vars funcs))
670  (with-acode-declarations p2decls (rewrite-acode-form body asserted-type)))
671
672(def-acode-rewrite acode-rewrite-%decls-body %decls-body asserted-type (form p2decls)
673  (with-acode-declarations p2decls (rewrite-acode-form form asserted-type)))
674
675
676;;; The backends may try to eliminate the &rest arg if the body is
677;;; obviously an APPLY that uses it.  We could do that here.
678(def-acode-rewrite acode-rewrite-lambda-bind lambda-bind asserted-type (vals req rest keys-p auxen body p2decls)
679  (declare (ignore keys-p rest))
680  (dolist (var req)
681    (acode-maybe-punt-var var (pop vals)))
682  (dolist (val vals)
683    (rewrite-acode-form val))
684  (do* ((auxvars (car auxen) (cdr auxvars))
685        (auxvals (cadr auxen) (cdr auxvals)))
686       ((null auxvars))
687    (acode-maybe-punt-var (car auxvars) (car auxvals)))
688  (with-acode-declarations p2decls (rewrite-acode-form body asserted-type))
689)
690
691;;; The frontend may have type-constrained the value.  That should probably
692;;; happen here.
693(def-acode-rewrite acode-rewrite-setq-lexical setq-lexical asserted-type (var value)
694  (rewrite-acode-form value (or (and *acode-rewrite-trust-declarations*
695                                     (var-declared-type var))
696                                t)))
697
698(def-acode-rewrite acode-rewrite-unwind-protect unwind-protect asserted-type (protected-form cleanup-form)
699  (rewrite-acode-form protected-form asserted-type)
700  (rewrite-acode-form cleanup-form))
701
702(def-acode-rewrite acode-rewrite-setq-special (global-setq setq-special) asserted-type (sym val)
703  (declare (ignore sym))
704  (rewrite-acode-form val))
705
706(def-acode-rewrite acode-rewrite-immediate-get-xxx immediate-get-xxx asserted-type (bits ptr offset)
707  (declare (ignore bits))
708  (rewrite-acode-form ptr)
709  (rewrite-acode-form offset))
710
711(def-acode-rewrite with-variable-c-frame with-variable-c-frame asserted-type (size body)
712  (rewrite-acode-form size)
713  (rewrite-acode-form body asserted-type))
714
715(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)
716  (declare (ignore argspecs resultspec monitor))
717  (rewrite-acode-form address)
718  (dolist (val argvals) (rewrite-acode-form val)))
719
720(def-acode-rewrite acode-rewrite-%ilsl %ilsl asserted-type (&whole w count num)
721  (acode-constant-fold-numeric-binop  w count num '%ilsl))
722
723(def-acode-rewrite acode-rewrite-if if asserted-type (&whole w test true false)
724  (rewrite-acode-form test)
725  (rewrite-acode-form true asserted-type)
726  (rewrite-acode-form false asserted-type)
727  (multiple-value-bind (val constantp) (acode-constant-p test)
728    (when constantp
729      (let* ((form (if val true false)))
730        (setf (acode-operator w) (acode-operator form)
731              (acode-operands w) (acode-operands form)
732              (acode.asserted-type w) nil)))))
733
734
735(def-acode-rewrite acode-rewrite-%izerop %izerop asserted-type (&whole w cc form)
736  (rewrite-acode-form form)
737  (multiple-value-bind (val constantp) (acode-constant-p form)
738    (when constantp
739      (setf (acode-operator w)
740            (if (if (eq (car (acode-operands cc)) :eq) (eql val 0) (not (eql val 0)))
741                (%nx1-operator t)
742                (%nx1-operator nil))
743            (acode-operands w) nil
744            (acode.asserted-type w) nil))))
745
746(def-acode-rewrite acode-rewrite-eq eq asserted-type (&whole w cc x y)
747  (rewrite-acode-form x)
748  (rewrite-acode-form y)
749  (multiple-value-bind (xval xconst) (acode-constant-p x)
750    (multiple-value-bind (yval yconst) (acode-constant-p y)
751      (when (and xconst yconst)
752        (setf (acode-operator w)
753              (if (if (eq (car (acode-operands cc)) :eq) (eql xval yval) (not (eql xval yval)))
754                (%nx1-operator t)
755                (%nx1-operator nil))
756              (acode-operands w) nil
757              (acode.asserted-type w) nil)))))
758
759(def-acode-rewrite acode-rewrite-with-c-frame with-c-frame asserted-type (body)
760  (rewrite-acode-form body asserted-type))
761
762(def-acode-rewrite acode-rewrite-ash ash asserted-type (&whole w num amt)
763  (or (acode-constant-fold-numeric-binop w num amt 'ash)
764      (let* ((maxbits (target-word-size-case
765                       (32 29)
766                       (64 60)))
767             (cnum (acode-constant-p num))
768             (camt (acode-constant-p amt))
769             (trust-decls *acode-rewrite-trust-declarations*)
770             (fixnum-type *nx-target-fixnum-type*)
771             (natural-type *nx-target-natural-type*))
772        (cond ((eql camt 0) (setf (acode-operator w) (%nx1-operator require-integer)
773                                  (cdr (acode-operands w)) nil
774                                  (acode.asserted-type w) nil))
775              ((and (typep camt fixnum-type)
776                    (< camt 0))
777               (if (acode-form-typep num fixnum-type trust-decls)
778                 (setf (acode-operator w) (%nx1-operator %iasr)
779                       (acode-operands w) (list (make-acode (%nx1-operator fixnum)
780                                                            (- camt))
781                                                num)
782                       (acode.asserted-type w) nil)
783                 (if (acode-form-typep num natural-type trust-decls)
784                   (if (< (- camt) (arch::target-nbits-in-word
785                                    (backend-target-arch *target-backend*)))
786                     (setf (acode-operator w) (%nx1-operator natural-shift-right)
787                           (cadr (acode-operands w)) (make-acode (%nx1-operator fixnum) (- camt))
788                           (acode.asserted-type w) nil)
789
790                     (setf (acode-operator w) (%nx1-operator progn)
791                           (acode-operands w) (list (list (make-acode (%nx1-operator require-integer) num)
792                                                          (make-acode (%nx1-operator fixnum) 0)))
793                           (acode.asserted-type w) nil)))))
794              ((and (typep camt 'fixnum)
795                    (<= 0 camt maxbits)
796                    (or (acode-form-typep num `(signed-byte ,(- (1+ maxbits) camt)) trust-decls)
797                        (and (acode-form-typep num fixnum-type trust-decls)
798                             (subtypep asserted-type fixnum-type))))
799               (setf (acode-operator w) (%nx1-operator %ilsl)
800                     (acode-operands w) (list amt num)
801                     (acode.asserted-type w) nil))
802              ((and (typep camt 'fixnum)
803                    (< 0 camt (arch::target-nbits-in-word
804                               (backend-target-arch *target-backend*)))
805                    (acode-form-typep num natural-type trust-decls)
806                    (subtypep asserted-type natural-type))
807               (setf (acode-operator w) (%nx1-operator natural-shift-left)
808                     (acode.asserted-type w) nil))
809              ((typep cnum 'fixnum)
810               (let* ((field-width (1+ (integer-length cnum)))
811                      ;; num fits in a `(signed-byte ,field-width)
812                      (max-shift (- (1+ maxbits) field-width)))
813                 (if (and (>= max-shift 0)
814                          (acode-form-typep amt `(mod ,(1+ max-shift)) trust-decls))
815                   (setf (acode-operator w) (%nx1-operator %ilsl)
816                         (acode-operands w) (list amt num)
817                         (acode.asserted-type w) nil))))
818              ((or (and (subtypep asserted-type fixnum-type)
819                        (acode-form-typep num fixnum-type trust-decls)
820                        (target-word-size-case
821                         (32 (acode-form-typep amt '(signed-byte 5) trust-decls))
822                         (64 (acode-form-typep amt '(signed-byte 6) trust-decls))))
823                   (let* ((numtype (specifier-type (acode-form-type num trust-decls)))
824                          (amttype (specifier-type (acode-form-type amt trust-decls)))
825                          (fixtype (specifier-type fixnum-type)))
826                     (if (and (typep numtype 'numeric-ctype)
827                              (csubtypep numtype fixtype)
828                              (typep amttype 'numeric-ctype)
829                              (csubtypep amttype fixtype))
830                       (let* ((highnum (numeric-ctype-high numtype))
831                              (lownum (numeric-ctype-low numtype))
832                              (widenum (if (> (integer-length highnum)
833                                              (integer-length lownum))
834                                         highnum
835                                         lownum))
836                              (maxleft (numeric-ctype-high amttype)))
837                         
838                         (and (>= (numeric-ctype-low amttype)
839                                        (target-word-size-case
840                                         (32 -31)
841                                         (64 -63)))
842                                    (< maxleft
843                                       (arch::target-nbits-in-word (backend-target-arch *target-backend*)))
844                                    (typep (ignore-errors (ash widenum maxleft))
845                                           fixnum-type))))))
846               (setf (acode-operator w) (%nx1-operator fixnum-ash)
847                     (acode.asserted-type w) nil))))))
848
849(def-acode-rewrite acode-rewrite-multiple-value-call multiple-value-call asserted-type (callable formlist)
850  (when (acode-p callable)
851    (rewrite-acode-form callable))
852  (dolist (form formlist) (rewrite-acode-form form)))
853
854(def-acode-rewrite acode-rewrite-numcmp numcmp asserted-type (&whole w cc num1 num2)
855  (let* ((ccval (car (acode-operands cc)))
856         (fn (case ccval
857               (:lt '<)
858               (:le '<=)
859               (:eq '=)
860               (:ne '/=)
861               (:ge '>=)
862               (:gt '>))))
863    ;;(acode-rewrite-binop-for-numeric-contagion num1 num2 *acode-rewrite-trust-declarations*)
864    (multiple-value-bind (v1 c1) (acode-constant-p num1)
865      (multiple-value-bind (v2 c2) (acode-constant-p num2)
866        (multiple-value-bind (constval error)
867            (if (and c1 c2)
868              (ignore-errors (funcall fn v1 v2))
869              (values nil t))
870          (if (not error)
871            (acode-rewrite-as-constant-ref w constval)
872            (let* ((op (acode-operator w)))
873              (or (acode-strength-reduce-binop w num1 num2 *nx-target-fixnum-type* op (%nx1-operator %i<>))
874                  (acode-strength-reduce-binop w num1 num2 *nx-target-natural-type* op (%nx1-operator %natural<>))
875                  (acode-strength-reduce-binop w num1 num2 'double-float op (%nx1-operator double-float-compare))
876                  (acode-strength-reduce-binop w num1 num2 'single-float op (%nx1-operator short-float-compare))
877                  ;; Could try contagion here
878                  ))))))))
Note: See TracBrowser for help on using the repository browser.