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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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