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

Last change on this file since 16571 was 16571, checked in by gb, 6 years ago

rewrite (more of) lambda, flet. labels, self-calls.

File size: 44.6 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    (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-cxr (%car %cdr car cdr) asserted-type (&whole w cell)
566  (rewrite-acode-form cell)
567  (multiple-value-bind (val constantp) (acode-constant-p cell)
568    (when (and constantp (typep val 'list) (not (and *load-time-eval-token* (eq (car val) *load-time-eval-token*))))
569      (let* ((op (acode-operator w)))
570        (acode-rewrite-as-constant-ref w (if (or (eql op (%nx1-operator car))
571                                                 (eql op (%nx1-operator %car)))
572                                           (car val)
573                                           (cdr val)))))))
574
575
576
577                   
578(def-acode-rewrite acode-rewrite-%gvector %gvector asserted-type  (&whole w arglist)
579  (let* ((all-args (append (car arglist) (reverse (cadr arglist)))))
580    (dolist (arg all-args)
581      (rewrite-acode-form arg))
582    ;; Could try to map constant subtag to type here
583    ))
584
585(def-acode-rewrite acode-rewrite-char-code (%char-code char-code) asserted-type  (&whole w c)
586  (rewrite-acode-form c)
587  (let* ((char (acode-constant-p c)))
588    (when (typep char 'character)
589      (let* ((code (char-code char)))
590        (setf (acode-operator w) (%nx1-operator fixnum)
591              (acode-operands w) (list code)
592              (acode.asserted-type w) nil)))))
593
594(def-acode-rewrite acode-rewrite-logior (logior2 %ilogior2 %natural-logior) asserted-type  (&whole w x y) 
595  (or (acode-constant-fold-numeric-binop  w x y 'logior)
596      (acode-strength-reduce-binop w x y *nx-target-fixnum-type* (%nx1-operator logior2) (%nx1-operator %ilogior2))
597      (acode-strength-reduce-binop w x y *nx-target-natural-type* (%nx1-operator logior2) (%nx1-operator %natural-logior)))
598)
599
600(def-acode-rewrite acode-rewrite-logand (logand2 %ilogand2 %natural-logand) asserted-type  (&whole w x y) 
601  (or (acode-constant-fold-numeric-binop  w x y 'logand)
602      (acode-strength-reduce-binop w x y *nx-target-fixnum-type* (%nx1-operator logand2) (%nx1-operator %ilogand2))
603      (acode-strength-reduce-binop w x y *nx-target-natural-type* (%nx1-operator logand2) (%nx1-operator %natural-logand))
604      (cond ((eql -1 (acode-fixnum-form-p x))
605             (setf (acode-operator w) (%nx1-operator require-integer)
606                   (acode-operands w) (list y)
607                   (acode.asserted-type w) nil)
608             t)
609            ((eql -1 (acode-fixnum-form-p y))
610             (setf (acode-operator w) (%nx1-operator require-integer)
611                   (acode-operands w) (list x)
612                   (acode.asserted-type w) nil)
613             t))))
614
615(def-acode-rewrite acode-rewrite-logxor (logxor2 %ilogxor2 %natural-logxor) asserted-type  (&whole w x y) 
616  (or (acode-constant-fold-numeric-binop  w x y 'logxor)
617      (acode-strength-reduce-binop w x y *nx-target-fixnum-type* (%nx1-operator logxor2) (%nx1-operator %ilogxor2))
618      (acode-strength-reduce-binop w x y *nx-target-natural-type* (%nx1-operator logxor2) (%nx1-operator %natural-logxor))))
619                                   
620
621   
622(def-acode-rewrite acode-rewrite-%ineg %ineg asserted-type (&whole w x)
623  (rewrite-acode-form x)
624  (let* ((val (acode-fixnum-form-p x))
625         (negated (if val (- val))))
626    (if negated
627      (setf (acode-operator w) (if (typep negated *nx-target-fixnum-type*)
628                                 (%nx1-operator fixnum)
629                                 (%nx1-operator immediate))
630            (acode-operands w) (list negated)
631            (acode.asserted-type w) nil))))
632
633(def-acode-rewrite rewrite-type-asserted-form type-asserted-form asserted-type (&whole w type form &optional check)
634  (declare (ignore check))
635  (rewrite-acode-form form type))
636
637(def-acode-rewrite rewrite-typed-form typed-form asserted-type (&whole w type form &optional check)
638  (rewrite-acode-form form (if (or check *acode-rewrite-trust-declarations*) type t)))
639
640(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)
641  (declare (ignore val)))
642
643
644(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))
645
646(def-acode-rewrite rewrite-call (call lexical-function-call builtin-call) asserted-type (&whole w callable arglist &optional spread-p)
647  (declare (ignore spread-p))
648  (when (acode-p callable)
649    (rewrite-acode-form callable))
650  (dolist (arg (car arglist))
651    (rewrite-acode-form arg))
652  (dolist (arg (cadr arglist))
653    (rewrite-acode-form arg)))
654
655
656(def-acode-rewrite acode-rewrite-arglist-form (list* %err-disp) asserted-type (&whole w arglist)
657  (dolist (arg (car arglist))
658    (rewrite-acode-form arg))
659  (dolist (arg (cadr arglist))
660    (rewrite-acode-form arg)))
661
662(def-acode-rewrite acode-rewrite-self-call self-call asserted-type (arglist &optional spread-p)
663  (let* ((vars (afunc-vars *nx-current-function*)))
664    (if (or spread-p (not (eql (length vars) (+ (length (car arglist)) (length (cadr arglist))))))
665      (setq vars nil))
666   
667    (dolist (arg (car arglist))
668      (let* ((v (pop vars)))
669        (if v
670          (rewrite-acode-form arg (var-declared-type v))
671          (rewrite-acode-form arg))))
672    (setq vars (reverse vars))
673    (dolist (arg (cadr arglist))
674      (let* ((v (pop vars)))
675        (if v
676          (rewrite-acode-form arg (var-declared-type v))
677          (rewrite-acode-form arg))
678      ))))
679
680
681(def-acode-rewrite acode-rewrite-formlist (list values %temp-list vector) asserted-type (formlist)
682  (dolist (form formlist) (rewrite-acode-form form)))
683
684(def-acode-rewrite acode-rewrite-multiple-value-bind multiple-value-bind asserted-type (vars valform body p2decls)
685  (declare (ignore vars))
686  (rewrite-acode-form valform)
687  (with-acode-declarations p2decls (rewrite-acode-form body asserted-type)))
688
689
690(def-acode-rewrite acode-rewrite-local-tagbody local-tagbody asserted-type (tags forms)
691  (declare (ignore tags))
692  (dolist (form forms) (rewrite-acode-form form)))
693
694(def-acode-rewrite acode-rewrite-tag-label tag-label asserted-type (&rest ignore)
695  (declare (ignore ignore)))
696
697(def-acode-rewrite acode-rewrite-local-block local-block asserted-type (tag body)
698  (declare (ignore tag))
699  (rewrite-acode-form body asserted-type))
700
701
702(def-acode-rewrite acode-rewrite-local-return-from local-return-from asserted-type (block value)
703  (declare (ignore block))
704  (rewrite-acode-form value))
705
706(def-acode-rewrite acode-rewrite-or or asserted-type (forms)
707  (dolist (form forms) (rewrite-acode-form form))
708  (do* ((forms forms (cdr forms)))
709       ((null (cdr forms)))
710    (multiple-value-bind (val constantp) (acode-constant-p (car forms))
711      (when (and val constantp)
712        (setf (cdr forms) nil)))))
713
714
715
716(def-acode-rewrite acode-rewrite-labels-flet (labels flet)  asserted-type (vars funcs body p2decls)
717  (declare (ignore vars))
718  (dolist (func funcs)
719    (let* ((*nx-current-function* func))
720      (rewrite-acode-form (afunc-acode func))))
721  (with-acode-declarations p2decls (rewrite-acode-form body asserted-type)))
722
723(def-acode-rewrite acode-rewrite-%decls-body %decls-body asserted-type (form p2decls)
724  (with-acode-declarations p2decls (rewrite-acode-form form asserted-type)))
725
726
727;;; The backends may try to eliminate the &rest arg if the body is
728;;; obviously an APPLY that uses it.  We could do that here.
729(def-acode-rewrite acode-rewrite-lambda-bind lambda-bind asserted-type (vals req rest keys-p auxen body p2decls)
730  (declare (ignore keys-p rest))
731  (dolist (var req)
732    (acode-maybe-punt-var var (pop vals)))
733  (dolist (val vals)
734    (rewrite-acode-form val))
735  (do* ((auxvars (car auxen) (cdr auxvars))
736        (auxvals (cadr auxen) (cdr auxvals)))
737       ((null auxvars))
738    (acode-maybe-punt-var (car auxvars) (car auxvals)))
739  (with-acode-declarations p2decls (rewrite-acode-form body asserted-type))
740)
741
742;;; The frontend may have type-constrained the value.  That should probably
743;;; happen here.
744(def-acode-rewrite acode-rewrite-setq-lexical setq-lexical asserted-type (var value)
745  (rewrite-acode-form value (or (and *acode-rewrite-trust-declarations*
746                                     (var-declared-type var))
747                                t)))
748
749(def-acode-rewrite acode-rewrite-unwind-protect unwind-protect asserted-type (protected-form cleanup-form)
750  (rewrite-acode-form protected-form asserted-type)
751  (rewrite-acode-form cleanup-form))
752
753(def-acode-rewrite acode-rewrite-setq-special (global-setq setq-special) asserted-type (sym val)
754  (declare (ignore sym))
755  (rewrite-acode-form val))
756
757(def-acode-rewrite acode-rewrite-immediate-get-xxx immediate-get-xxx asserted-type (bits ptr offset)
758  (declare (ignore bits))
759  (rewrite-acode-form ptr)
760  (rewrite-acode-form offset))
761
762(def-acode-rewrite with-variable-c-frame with-variable-c-frame asserted-type (size body)
763  (rewrite-acode-form size)
764  (rewrite-acode-form body asserted-type))
765
766(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)
767  (declare (ignore argspecs resultspec monitor))
768  (rewrite-acode-form address)
769  (dolist (val argvals) (rewrite-acode-form val)))
770
771(def-acode-rewrite acode-rewrite-%ilsl %ilsl asserted-type (&whole w count num)
772  (acode-constant-fold-numeric-binop  w count num '%ilsl))
773
774(def-acode-rewrite acode-rewrite-if if asserted-type (&whole w test true false)
775  (rewrite-acode-form test)
776  (rewrite-acode-form true asserted-type)
777  (rewrite-acode-form false asserted-type)
778  (multiple-value-bind (val constantp) (acode-constant-p test)
779    (when constantp
780      (let* ((form (if val true false)))
781        (setf (acode-operator w) (acode-operator form)
782              (acode-operands w) (acode-operands form)
783              (acode.asserted-type w) nil)))))
784
785
786(def-acode-rewrite acode-rewrite-%izerop %izerop asserted-type (&whole w cc form)
787  (rewrite-acode-form form)
788  (multiple-value-bind (val constantp) (acode-constant-p form)
789    (when constantp
790      (setf (acode-operator w)
791            (if (if (eq (car (acode-operands cc)) :eq) (eql val 0) (not (eql val 0)))
792                (%nx1-operator t)
793                (%nx1-operator nil))
794            (acode-operands w) nil
795            (acode.asserted-type w) nil))))
796
797(def-acode-rewrite acode-rewrite-eq eq asserted-type (&whole w cc x y)
798  (rewrite-acode-form x)
799  (rewrite-acode-form y)
800  (multiple-value-bind (xval xconst) (acode-constant-p x)
801    (multiple-value-bind (yval yconst) (acode-constant-p y)
802      (when (and xconst yconst)
803        (setf (acode-operator w)
804              (if (if (eq (car (acode-operands cc)) :eq) (eql xval yval) (not (eql xval yval)))
805                (%nx1-operator t)
806                (%nx1-operator nil))
807              (acode-operands w) nil
808              (acode.asserted-type w) nil)))))
809
810(def-acode-rewrite acode-rewrite-with-c-frame with-c-frame asserted-type (body)
811  (rewrite-acode-form body asserted-type))
812
813(def-acode-rewrite acode-rewrite-ash ash asserted-type (&whole w num amt)
814  (or (acode-constant-fold-numeric-binop w num amt 'ash)
815      (let* ((maxbits (target-word-size-case
816                       (32 29)
817                       (64 60)))
818             (newtype nil)
819             (cnum (acode-constant-p num))
820             (camt (acode-constant-p amt))
821             (trust-decls *acode-rewrite-trust-declarations*)
822             (fixnum-type *nx-target-fixnum-type*)
823             (natural-type *nx-target-natural-type*))
824        (cond ((eql camt 0) (setf (acode-operator w) (%nx1-operator require-integer)
825                                  (cdr (acode-operands w)) nil
826                                  (acode.asserted-type w) nil))
827              ((and (typep camt fixnum-type)
828                    (< camt 0))
829               (if (acode-form-typep num fixnum-type trust-decls)
830                 (setf (acode-operator w) (%nx1-operator %iasr)
831                       (acode-operands w) (list (make-acode (%nx1-operator fixnum)
832                                                            (- camt))
833                                                num)
834                       (acode.asserted-type w) nil)
835                 (if (acode-form-typep num natural-type trust-decls)
836                   (if (< (- camt) (arch::target-nbits-in-word
837                                    (backend-target-arch *target-backend*)))
838                     (setf (acode-operator w) (%nx1-operator natural-shift-right)
839                           (cadr (acode-operands w)) (make-acode (%nx1-operator fixnum) (- camt))
840                           (acode.asserted-type w) nil)
841
842                     (setf (acode-operator w) (%nx1-operator progn)
843                           (acode-operands w) (list (list (make-acode (%nx1-operator require-integer) num)
844                                                          (make-acode (%nx1-operator fixnum) 0)))
845                           (acode.asserted-type w) nil)))))
846              ((and (typep camt 'fixnum)
847                    (<= 0 camt maxbits)
848                    (or (acode-form-typep num `(signed-byte ,(- (1+ maxbits) camt)) trust-decls)
849                        (and (acode-form-typep num fixnum-type trust-decls)
850                             (subtypep asserted-type fixnum-type))))
851               (setf (acode-operator w) (%nx1-operator %ilsl)
852                     (acode-operands w) (list amt num)
853                     (acode.asserted-type w) nil))
854              ((and (typep camt 'fixnum)
855                    (< 0 camt (arch::target-nbits-in-word
856                               (backend-target-arch *target-backend*)))
857                    (acode-form-typep num natural-type trust-decls)
858                    (subtypep asserted-type natural-type))
859               (setf (acode-operator w) (%nx1-operator natural-shift-left)
860                     (acode.asserted-type w) nil))
861              ((typep cnum 'fixnum)
862               (let* ((field-width (1+ (integer-length cnum)))
863                      ;; num fits in a `(signed-byte ,field-width)
864                      (max-shift (- (1+ maxbits) field-width)))
865                 (if (and (>= max-shift 0)
866                          (acode-form-typep amt `(mod ,(1+ max-shift)) trust-decls))
867                   (setf (acode-operator w) (%nx1-operator %ilsl)
868                         (acode-operands w) (list amt num)
869                         (acode.asserted-type w) nil))))
870              ((and  (setq newtype (bounded-integer-type-for-ash
871                                  (acode-form-type num trust-decls)
872                                   (acode-form-type amt trust-decls)))
873                    (subtypep (type-specifier newtype) fixnum-type))
874               (when (and (acode-form-typep num fixnum-type trust-decls)
875                          (acode-form-typep amt fixnum-type trust-decls))
876                 (setf (acode-operator w) (%nx1-operator fixnum-ash)))
877               (setf (acode.asserted-type w) (type-specifier newtype)))))))
878
879(def-acode-rewrite acode-rewrite-multiple-value-call multiple-value-call asserted-type (callable formlist)
880  (when (acode-p callable)
881    (rewrite-acode-form callable))
882  (dolist (form formlist) (rewrite-acode-form form)))
883
884(def-acode-rewrite acode-rewrite-numcmp numcmp asserted-type (&whole w cc num1 num2)
885  (let* ((ccval (car (acode-operands cc)))
886         (fn (case ccval
887               (:lt '<)
888               (:le '<=)
889               (:eq '=)
890               (:ne '/=)
891               (:ge '>=)
892               (:gt '>))))
893    (rewrite-acode-form num1)
894    (rewrite-acode-form num2)
895    ;;(acode-rewrite-binop-for-numeric-contagion num1 num2 *acode-rewrite-trust-declarations*)
896    (multiple-value-bind (v1 c1) (acode-constant-p num1)
897      (multiple-value-bind (v2 c2) (acode-constant-p num2)
898        (multiple-value-bind (constval error)
899            (if (and c1 c2)
900              (ignore-errors (funcall fn v1 v2))
901              (values nil t))
902          (if (not error)
903            (acode-rewrite-as-constant-ref w constval)
904            (let* ((op (acode-operator w)))
905              (or (acode-strength-reduce-binop w num1 num2 *nx-target-fixnum-type* op (%nx1-operator %i<>))
906                  (acode-strength-reduce-binop w num1 num2 *nx-target-natural-type* op (%nx1-operator %natural<>))
907                  (acode-strength-reduce-binop w num1 num2 'double-float op (%nx1-operator double-float-compare))
908                  (acode-strength-reduce-binop w num1 num2 'single-float op (%nx1-operator short-float-compare))
909                  ;; Could try contagion here
910                  ))))))))
Note: See TracBrowser for help on using the repository browser.