source: branches/1.2-devel/ccl/compiler/acode-rewrite.lisp @ 15278

Last change on this file since 15278 was 7768, checked in by gb, 12 years ago

new file

File size: 15.0 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2007, Clozure Associates
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL 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-post-trust-decls* nil)
21
22;;; Rewrite acode trees.
23
24(next-nx-defops)
25(defvar *acode-rewrite-functions* nil)
26(let* ((newsize (%i+ (next-nx-num-ops) 10))
27       (old *acode-rewrite-functions*)
28       (oldsize (length old)))
29  (declare (fixnum newsize oldsize))
30  (unless (>= oldsize newsize)
31    (let* ((v (make-array newsize :initial-element nil)))
32      (dotimes (i oldsize (setq *acode-rewrite-functions* v))
33        (setf (svref v i) (svref old i))))))
34
35(eval-when (:compile-toplevel :load-toplevel :execute)
36  (defmacro def-acode-rewrite (name operator-list arglist &body body)
37    (if (atom operator-list)
38      (setq operator-list (list operator-list)))
39    (multiple-value-bind (body decls)
40        (parse-body body nil t)
41      (collect ((let-body))
42        (dolist (operator operator-list)
43          (let-body `(setf (svref *acode-rewrite-functions* (logand operator-id-mask (%nx1-operator ,operator))) fun)))
44        (destructuring-bind (op whole type) arglist
45        `(let* ((fun (nfunction ,name 
46                                (lambda (,op ,whole ,type)
47                                  (declare (ignorable ,op ,type))
48                                  ,@decls
49                                  (block ,name ,@body)))))
50          ,@(let-body)))))))
51
52;;; Don't walk the form (that's already happened.)
53(defun acode-post-form-type (form)
54  (when (acode-p form)
55    (let* ((op (acode-operator form))
56           (operands (cdr form)))
57      (cond ((and *acode-post-trust-decls*
58                  (eq op (%nx1-operator typed-form)))
59             (acode-operand 0 operands))
60            ((eq op (%nx1-operator fixnum))
61             'fixnum)
62            ((eq op (%nx1-operator immediate))
63             (type-of (acode-operand 0 operands)))
64            (t t)))))
65
66(defun acode-constant-p (form)
67  (let* ((form (acode-unwrapped-form form)))
68    (or (eq form *nx-nil*)
69        (eq form *nx-t*)
70        (let* ((operator (if (acode-p form) (acode-operator form))))
71          (or (eq operator (%nx1-operator fixnum))
72              (eq operator (%nx1-operator immediate)))))))
73
74(defun acode-post-form-typep (form type)
75  (let* ((ctype (specifier-type type))
76         (form (acode-unwrapped-form form)))
77    (cond ((eq form *nx-nil*) (ctypep nil ctype))
78          ((eq form *nx-t*) (ctypep t ctype))
79          ((not (acode-p form)) (values nil nil))
80          (t
81           (let* ((op (acode-operator form))
82                  (operands (cdr form)))
83             (cond ((and *acode-post-trust-decls*
84                         (eq op (%nx1-operator typed-form)))
85                    (subtypep (acode-operand 0 operands) type))
86                   ((or (eq op (%nx1-operator fixnum))
87                        (eq op (%nx1-operator immediate)))
88                    (ctypep (acode-operand 0 operands) (specifier-type type)))
89                   (t (values nil nil))))))))
90
91             
92
93(defun rewrite-acode-ref (ref &optional (type t))
94  (let* ((form (car ref)))
95    (if (acode-p form)
96      (let* ((op (acode-operator form))
97             (rewrite (svref *acode-rewrite-functions* (logand op operator-id-mask))))
98        (when rewrite
99          (let* ((new (funcall rewrite op (cdr form) type)))
100            (when new
101              (setf (car ref) new)
102              t)))))))
103
104;;; Maybe ewrite the operands of a binary real arithmetic operation
105(defun acode-post-binop-numeric-contagion (pform1 pform2)
106  (let* ((form1 (car pform1))
107         (form2 (car pform2)))
108    (cond ((acode-post-form-typep form1 'double-float)
109           (unless (acode-post-form-typep form2 'double-float)
110             (let* ((c2 (acode-real-constant-p form2)))
111               (if c2
112                 (setf (car pform2)
113                       (make-acode (%nx1-operator immediate)
114                                   (float c2 0.0d0)))
115                 (if (acode-post-form-typep form2 'fixnum)
116                   (setf (car pform2)
117                         (make-acode (%nx1-operator typed-form)
118                                     'double-float
119                                     (make-acode (%nx1-operator %fixnum-to-double)
120                                                 form2))))))))
121          ((acode-post-form-typep form2 'double-float)
122           (let* ((c1 (acode-real-constant-p form1)))
123             (if c1
124               (setf (car pform1)
125                     (make-acode (%nx1-operator immediate)
126                                 (float c1 0.0d0)))
127               (if (acode-post-form-typep form1 'fixnum)
128                 (setf (car pform1)
129                       (make-acode (%nx1-operator typed-form)
130                                   'double-float
131                                   (make-acode (%nx1-operator %fixnum-to-double)
132                                               form1)))))))
133          ((acode-post-form-typep form1 'single-float)
134           (unless (acode-post-form-typep form2 'single-float)
135             (let* ((c2 (acode-real-constant-p form2)))
136               (if c2
137                 (setf (car pform2) (make-acode (%nx1-operator immediate)
138                                                (float c2 0.0f0)))
139                 (if (acode-post-form-typep form2 'fixnum)
140                   (setf (car pform2)
141                         (make-acode (%nx1-operator typed-form)
142                                     'single-float
143                                     (make-acode (%nx1-operator %fixnum-to-single)
144                                                 form2))))))))
145          ((acode-post-form-typep form2 'single-float)
146           (let* ((c1 (acode-real-constant-p form1)))
147             (if c1
148               (setf (car pform1) (make-acode (%nx1-operator immediate)
149                                              (float c1 0.0f0)))
150
151               (if (acode-post-form-typep form1 'fixnum)
152                 (setf (car pform1)
153                       (make-acode (%nx1-operator typed-form)
154                                   'single-float
155                                   (make-acode (%nx1-operator %fixnum-to-single)
156                                               form1))))))))))
157
158(defun constant-fold-acode-binop (function x y)
159  (let* ((constant-x (acode-real-constant-p x))
160         (constant-y (acode-real-constant-p y)))
161    (if (and constant-x constant-y)
162      (let* ((result (ignore-errors (funcall function x y))))
163        (when result
164          (nx1-form result))))))
165
166(defun acode-rewrite-and-fold-binop (function args)
167  (rewrite-acode-ref args)
168  (rewrite-acode-ref (cdr args))
169  (constant-fold-acode-binop function (car args) (cadr args)))
170
171(defun rewrite-acode-forms (forms)
172  (do* ((head forms (cdr head)))
173       ((null head))
174    (rewrite-acode-ref head)))
175
176(defun acode-assert-type (actualtype operator operands assertedtype)
177  (make-acode (%nx1-operator typed-form)
178              (type-specifier (type-intersection (specifier-type actualtype)
179                                                 (specifier-type assertedtype)))
180              (cons operator operands)))
181
182(def-acode-rewrite acode-rewrite-progn progn (op w type)
183  (rewrite-acode-forms w))
184
185(def-acode-rewrite acode-rewrite-not not (op w type)
186  (rewrite-acode-ref w))
187
188(def-acode-rewrite acode-rewrite-%i+ %i+ (op w type)
189  (or 
190   (acode-rewrite-and-fold-binop '+ w)
191   ;; TODO: maybe cancel overflow check, assert FIXNUM result.
192   (acode-assert-type 'integer op w type)))
193
194(def-acode-rewrite acode-rewrite-%i- %i- (op w type)
195  (or
196   (acode-rewrite-and-fold-binop '- w))
197   ;; TODO: maybe cancel overflow check, assert FIXNUM result.
198   (acode-assert-type 'integer op w type)) 
199
200(def-acode-rewrite acode-rewrite-%ilsl %ilsl (op w type)
201  (or
202   (acode-rewrite-and-fold-binop '%ilsl w)
203   (acode-assert-type 'fixnum op w type)))
204
205(def-acode-rewrite acode-rewrite-%ilogand2 %ilogand2 (op w type)
206  (or
207   (acode-rewrite-and-fold-binop 'logand w)
208   ;; If either argument's an UNSIGNED-BYTE constant, the result
209   ;; is an UNSIGNED-BYTE no greater than that constant.
210   (destructuring-bind (x y) w
211     (let* ((fix-x (acode-fixnum-form-p x))
212            (fix-y (acode-fixnum-form-p y)))
213       (acode-assert-type (if fix-x
214                            `(integer 0 ,fix-x)
215                            (if fix-y
216                              `(integer 0 ,fix-y)
217                              'fixnum))
218                          op w type)))))
219
220(def-acode-rewrite acode-rewrite-%ilogior2 %ilogior2 (op w type)
221  (or
222   (acode-rewrite-and-fold-binop 'logior w)
223   ;; If either argument's an UNSIGNED-BYTE constant, the result
224   ;; is an UNSIGNED-BYTE no greater than that constant.
225   (destructuring-bind (x y) w
226     (let* ((fix-x (acode-fixnum-form-p x))
227            (fix-y (acode-fixnum-form-p y)))
228       (acode-assert-type (if fix-x
229                            `(integer 0 ,fix-x)
230                            (if fix-y
231                              `(integer 0 ,fix-y)
232                              'fixnum))
233                          op w type)))))
234
235(def-acode-rewrite acode-rewrite-ilogbitp (logbitp %ilogbitp) (op w type)
236  (or (acode-rewrite-and-fold-binop 'logbitp w)
237      (acode-assert-type 'boolean op w type)))
238
239(def-acode-rewrite acode-rewrite-eq eq (op w type)
240  (or (acode-rewrite-and-fold-binop 'eq w)
241      (acode-assert-type 'boolean op w type)))
242
243(def-acode-rewrite acode-rewrite-neq neq (op w type)
244  (or (acode-rewrite-and-fold-binop 'neq w)
245      (acode-assert-type 'boolean op w type))  )
246
247(def-acode-rewrite acode-rewrite-list list (op w type)
248  (rewrite-acode-forms (car w))
249  (acode-assert-type 'list op w type))
250
251(def-acode-rewrite acode-rewrite-values values (op w type)
252  (rewrite-acode-forms (car w)))
253
254(def-acode-rewrite acode-rewrite-if if (op w type)
255  (rewrite-acode-forms w)
256  (destructuring-bind (test true &optional (false *nx-nil*)) w
257    (if (acode-constant-p test)
258      (if (eq *nx-nil* (acode-unwrapped-form test))
259        false
260        true))))
261
262(def-acode-rewrite acode-rewrite-or or (op w type)
263  (rewrite-acode-forms (car w))
264  ;; Try to short-circuit if there are any true constants.
265  ;; The constant-valued case will return a single value.
266  (do* ((forms w (cdr forms)))
267       ((null (cdr forms)))
268    (let* ((form (car forms)))
269      (when (and (acode-constant-p form)
270                 (not (eq *nx-nil* (acode-unwrapped-form form))))
271        (progn
272          (rplacd forms nil)
273          (return))))))
274
275(def-acode-rewrite acode-rewrite-%fixnum-ref (%fixnum-ref %fixnum-ref-natural) (op w type)
276  (rewrite-acode-forms w))
277
278(def-acode-rewrite acode-rewrite-multiple-value-prog1 multiple-value-prog1 (op w type)
279  (rewrite-acode-forms w))
280
281(def-acode-rewrite acode-rewrite-multiple-value-bind multiple-value-bind (op w type)
282  (rewrite-acode-forms (cdr w)))
283
284(def-acode-rewrite acode-rewrite-multiple-value-call multiple-value-call (op w type)
285  (rewrite-acode-forms w))
286
287(def-acode-rewrite acode-rewrite-typed-form typed-form (op w type)
288  (let* ((ourtype (car w)))
289    (rewrite-acode-ref (cdr w) ourtype)
290    (let* ((subform (cadr w)))
291      (and (acode-p subform) (eq (acode-operator subform) op) subform))))
292
293;; w: vars, list of initial-value forms, body
294(def-acode-rewrite acode-rewrite-let (let let*) (op w type)
295  (collect ((newvars)
296            (newvals))
297    (do* ((vars (car w) (cdr vars))
298          (vals (cadr w) (cdr vals)))
299         ((null vars)
300          (rplaca w (newvars))
301          (rplaca (cdr w) (newvals))
302          (rewrite-acode-ref (cddr w))
303          (unless (car w) (caddr w)))
304      (rewrite-acode-ref (car vals))
305      (let* ((var (car vars))
306             (bits (nx-var-bits var)))
307        (cond ((logbitp $vbitpuntable bits)
308               (setf (var-bits var)
309                     (logior (ash 1 $vbitpunted) bits)
310                     (var-ea var) (car vals)))
311              (t
312               (newvars var)
313               (newvals (car vals))))))))
314       
315   
316     
317
318
319
320(def-acode-rewrite acode-rewrite-lexical-reference lexical-reference (op w type)
321  (let* ((var (car w)))
322    (if (acode-punted-var-p var)
323      (var-ea var))))
324
325(def-acode-rewrite acode-rewrite-add2 add2 (op w type)
326  (or (acode-rewrite-and-fold-binop '+ w)
327      (progn
328        (acode-post-binop-numeric-contagion w (cdr w))
329        (let* ((xtype (acode-post-form-type (car w)))
330               (ytype (acode-post-form-type (cadr w))))
331          (cond ((and (subtypep xtype 'double-float)
332                      (subtypep ytype 'double-float))
333                 (make-acode (%nx1-operator typed-form)
334                             'double-float
335                             (make-acode* (%nx1-operator %double-float+-2)
336                                          w)))
337                ((and (subtypep xtype 'single-float)
338                      (subtypep ytype 'single-float))
339                 (make-acode (%nx1-operator typed-form)
340                             'single-float
341                             (make-acode* (%nx1-operator %short-float+-2)
342                                          w)))
343                ((and (subtypep xtype 'fixnum)
344                      (subtypep ytype 'fixnum))
345                 (make-acode (%nx1-operator typed-form)
346                             'fixnum
347                             (make-acode (%nx1-operator %i+)
348                                         (car w)
349                                         (cadr w)
350                                         (not (subtypep type 'fixnum))))))))))
351
352(def-acode-rewrite acode-rewrite-sub2 sub2 (op w type)
353  (or (acode-rewrite-and-fold-binop '- w)
354      (progn
355        (acode-post-binop-numeric-contagion w (cdr w))
356        (let* ((xtype (acode-post-form-type (car w)))
357               (ytype (acode-post-form-type (cadr w))))
358          (cond ((and (subtypep xtype 'double-float)
359                      (subtypep ytype 'double-float))
360                 (make-acode (%nx1-operator typed-form)
361                             'double-float
362                             (make-acode* (%nx1-operator %double-float--2)
363                                          w)))
364                ((and (subtypep xtype 'single-float)
365                      (subtypep ytype 'single-float))
366                 (make-acode (%nx1-operator typed-form)
367                             'single-float
368                             (make-acode* (%nx1-operator %short-float--2)
369                                          w)))
370                ((and (subtypep xtype 'fixnum)
371                      (subtypep ytype 'fixnum))
372                 (make-acode (%nx1-operator typed-form)
373                             'fixnum
374                             (make-acode (%nx1-operator %i-)
375                                         (car w)
376                                         (cadr w)
377                                         (not (subtypep type 'fixnum))))))))))
378                 
379
Note: See TracBrowser for help on using the repository browser.