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

Last change on this file since 14705 was 14705, checked in by gb, 9 years ago

Still a work in progress, but ... in progress, again.

File size: 13.8 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2007-2010 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19
20(defvar *acode-rewrite-tail-allow* nil)
21(defvar *acode-rewrite-reckless* nil)
22(defvar *acode-rewrite-open-code-inline* nil)
23(defvar *acode-rewrite-trust-declarations* nil)
24(defvar *acode-rewrite-full-safety* nil)
25
26
27;;; Rewrite acode trees.
28
29(defvar *acode-rewrite-functions* nil)
30(let* ((newsize (%i+ (next-nx-num-ops) 10))
31       (old *acode-rewrite-functions*)
32       (oldsize (length old)))
33  (declare (fixnum newsize oldsize))
34  (unless (>= oldsize newsize)
35    (let* ((v (make-array newsize :initial-element nil)))
36      (dotimes (i oldsize (setq *acode-rewrite-functions* v))
37        (setf (svref v i) (svref old i))))))
38
39(eval-when (:compile-toplevel :load-toplevel :execute)
40  (defmacro def-acode-rewrite (name operator-list typecons arglist &body body)
41    (if (atom operator-list)
42      (setq operator-list (list operator-list)))
43    (multiple-value-bind (lambda-list whole)
44        (normalize-lambda-list arglist t)
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* ((whole-var (gensym "WHOLE")))
51            (multiple-value-bind (bindings binding-decls)
52                (%destructure-lambda-list lambda-list whole-var nil nil
53                                          :cdr-p t
54                                          :whole-p nil
55                                          :use-whole-var t
56                                          :default-initial-value nil)
57              (when whole
58                (setq bindings (nconc bindings (list `(,whole ,whole-var)))))
59             
60        `(let* ((fun (nfunction ,name 
61                                (lambda (,typecons ,whole-var)
62                                  (declare (ignorable ,typecons))
63                                  (block ,name
64                                    (let* ,(nreverse bindings)
65                                      ,@(when binding-decls `((declare ,@binding-decls)))
66                                      ,@decls
67                                      ,@body))))))
68          ,@(let-body)))))))))
69
70;;; Don't walk the form (that's already happened.)
71(defun acode-post-form-type (form)
72  (when (acode-p form)
73    (let* ((op (acode-operator form))
74           (operands (cdr form)))
75      (cond ((and *acode-rewrite-trust-declarations*
76                  (eq op (%nx1-operator typed-form)))
77             (acode-operand 0 operands))
78            ((eq op (%nx1-operator fixnum))
79             'fixnum)
80            ((eq op (%nx1-operator immediate))
81             (type-of (acode-operand 0 operands)))
82            (t t)))))
83
84(defun acode-constant-p (form)
85  ;; This returns (values constant-value constantp); some code
86  ;; may need to check constantp if constant-value is nil.
87  (let* ((form (acode-unwrapped-form-value form))
88         (op (if (acode-p form) (acode-operator form))))
89    (cond ((eql op (%nx1-operator nil))
90           (values nil t))
91          ((eql op (%nx1-operator t))
92           (values t t))
93          ((or (eql op (%nx1-operator fixnum))
94               (eql op (%nx1-operator immediate)))
95           (values (cadr form) t))
96          (t (values nil nil)))))
97
98
99(defun acode-post-form-typep (form type)
100  (let* ((ctype (specifier-type type))
101         (form (acode-unwrapped-form-value form)))
102    (cond ((nx-null form) (ctypep nil ctype))
103          ((nx-t form) (ctypep t ctype))
104          ((not (acode-p form)) (values nil nil))
105          (t
106           (let* ((op (acode-operator form))
107                  (operands (cdr form)))
108             (cond ((and *acode-rewrite-trust-declarations*
109                         (eq op (%nx1-operator typed-form)))
110                    (subtypep (acode-operand 0 operands) type))
111                   ((or (eq op (%nx1-operator fixnum))
112                        (eq op (%nx1-operator immediate)))
113                    (ctypep (acode-operand 0 operands) (specifier-type type)))
114                   (t (values nil nil))))))))
115
116(defun rewrite-acode-form (form type)
117  (when (acode-p form)
118    (let* ((op (acode-operator form))
119           (rest (acode-operands form))
120           (rewrite (svref *acode-rewrite-functions* (logand op operator-id-mask))))
121      (when rewrite
122        (let* ((new (cons op rest))
123               (type-cons (list type new)))
124          (setf (car form) (%nx1-operator type-asserted-form)
125                (cdr form) type-cons)
126          (funcall rewrite type-cons new))))))
127     
128   
129
130(defun acode-constant-fold-numeric-binop (type-cons whole form1 form2 function)
131  (rewrite-acode-form form1 t)
132  (rewrite-acode-form form2 t)
133  (let* ((v1 (acode-xxx-form-p form1 'number))
134         (v2 (acode-xxx-form-p form2 'number))
135         (val (and v1 v2 (ignore-errors (funcall function v1 v2)))))
136    (when val
137      (setf (car whole) (if (typep val *nx-target-fixnum-type*)
138                          (%nx1-operator fixnum)
139                          (%nx1-operator immediate))
140            (cadr whole) val
141            (cddr whole) nil
142            (car type-cons) (if (typep val 'integer)
143                             `(integer ,val ,val)
144                             (type-of val)))
145      val)))
146
147(defun acode-rewrite-decls (decls)
148  (if (fixnump decls)
149    (locally (declare (fixnum decls))
150      (setq *acode-rewrite-tail-allow* (neq 0 (%ilogand2 $decl_tailcalls decls))
151            *acode-rewrite-open-code-inline* (neq 0 (%ilogand2 $decl_opencodeinline decls))
152            *acode-rewrite-full-safety* (neq 0 (%ilogand2 $decl_full_safety decls))
153            *acode-rewrite-reckless* (neq 0 (%ilogand2 $decl_unsafe decls))
154            *acode-rewrite-trust-declarations* (neq 0 (%ilogand2 $decl_trustdecls decls))))))
155
156(defmacro with-acode-declarations (declsform &body body)
157  `(let* ((*acode-rewrite-tail-allow* *acode-rewrite-tail-allow*)
158          (*acode-rewrite-reckless* *acode-rewrite-reckless*)
159          (*acode-rewrite-open-code-inline* *acode-rewrite-open-code-inline*)
160          (*acode-rewrite-trust-declarations* *acode-rewrite-trust-declarations*)
161          (*acode-rewrite-full-safety* *acode-rewrite-full-safety*))
162     (acode-rewrite-decls ,declsform)
163     ,@body))
164
165(defun acode-maybe-punt-var (var initform)
166  (let* ((bits (nx-var-bits var)))
167    (declare (fixnum bits))
168    (cond ((and (logbitp $vbitpuntable var)
169                (not (logbitp $vbitpunted var)))
170           (nx-set-var-bits var (logior (ash 1 $vbitpunted) bits))
171           (rewrite-acode-form initform (or (var-inittype var) t))
172           (nx2-replace-var-refs var initform)
173           (setf (var-ea var) initform))
174          (t
175           (rewrite-acode-form initform t)))))
176           
177(defun acode-type-merge (type-cons derived)
178  (let* ((asserted (car type-cons))
179         (intersection (ignore-errors (type-specifier (specifier-type `(and ,asserted ,derived))))))
180    (when intersection
181      (setf (car type-cons) intersection))))
182
183
184#||
185(defun acode-set-immediate-type (type-cons acode-expr)
186  (let* ((type
187          (cond ((nx-null acode-expr) 'null)
188                ((nx-t acode-expr) '(eql t))
189                ((
190||#
191         
192   
193 
194
195(def-acode-rewrite acode-rewrite-lambda lambda-list type-cons (req opt rest keys auxen body p2-decls &optional code-note)
196  (declare (ignore code-note req rest))
197  (with-acode-declarations p2-decls
198    (dolist (optinit (cadr opt))
199      (rewrite-acode-form optinit t))
200    (dolist (keyinit (nth 3 keys))
201      (rewrite-acode-form keyinit t))
202    (do* ((auxvars (car auxen) (cdr auxvars))
203          (auxvals (cadr auxen) (cdr auxvals)))
204         ((null auxvars))
205      (acode-maybe-punt-var (car auxvars) (car auxvals)))
206    (rewrite-acode-form body (car type-cons))
207    (acode-type-merge type-cons (acode-form-type body *acode-rewrite-trust-declarations*))))
208
209(def-acode-rewrite acode-rewrite-progn progn type-cons (&rest forms)
210  (do* ((form (pop forms) (pop forms)))
211       ((null forms))
212    (if forms
213      (rewrite-acode-form form t)
214      (progn
215        (rewrite-acode-form form (car type-cons))
216        (acode-type-merge type-cons (acode-form-type form *acode-rewrite-trust-declarations*))))))
217
218(def-acode-rewrite acode-rewrite-prog1 prog1 type-cons (first &rest others)
219  (rewrite-acode-form first (car type-cons))
220  (dolist (other others) (rewrite-acode-form other t))
221  (acode-type-merge type-cons (acode-form-type first *acode-rewrite-trust-declarations*)))
222
223(def-acode-rewrite acode-rewrite-%slot-ref %slot-ref type-cons (instance idx)
224  (rewrite-acode-form instance t)
225  (rewrite-acode-form idx t))
226
227(def-acode-rewrite acode-rewrite-svref (%svref svref) type-cons (&whole w vector idx)
228  (rewrite-acode-form vector t)
229  (rewrite-acode-form idx t)
230  (let* ((cv (acode-constant-p vector)))
231    (when (if (eql (car w) (%nx1-operator svref))
232            (typep cv 'simple-vector)
233            (gvectorp cv))
234      (let* ((cidx (acode-fixnum-form-p idx)))
235        (when (and (typep cidx 'fixnum)
236                   (>= (the fixnum cidx) 0)
237                   (< (the fixnum cidx) (the fixnum (uvsize cv))))
238          (let* ((val (%svref cv cidx)))
239            (setf (car w) (if (nx1-target-fixnump val)
240                            (%nx1-operator fixnum)
241                            (%nx1-operator immediate))
242                  (cadr w) val
243                  (cddr w) nil)
244            (acode-type-merge type-cons (type-of val))))))))
245
246(def-acode-rewrite acode-rewrite-%sbchar %sbchar type-cons (&whole w string idx)
247  (rewrite-acode-form string t)
248  (rewrite-acode-form idx t)
249  (let* ((cv (acode-constant-p string)))
250    (when (typep cv 'simple-string)
251      (let* ((cidx (acode-fixnum-form-p idx)))
252        (when (and (typep cidx 'fixnum)
253                   (>= (the fixnum cidx) 0)
254                   (< (the fixnum cidx) (the fixnum (length cv))))
255          (let* ((val (%schar cv cidx)))
256            (setf (car w) (%nx1-operator immediate)
257                  (cadr w) val
258                  (cddr w) nil)
259            (acode-type-merge type-cons 'character)))))))
260
261(def-acode-rewrite acode-rewrite-svset (%svset svset) type-cons (vector idx value)
262  (rewrite-acode-form vector t)
263  (rewrite-acode-form idx t)
264  (rewrite-acode-form value (car type-cons))
265  (acode-type-merge type-cons (acode-form-type value *acode-rewrite-trust-declarations*)))
266
267(def-acode-rewrite acode-rewrite-consp consp type-cons (&whole w cc thing)
268  (rewrite-acode-form thing t)
269  (multiple-value-bind (cthing constantp) (acode-constant-p thing)
270    (if constantp
271      (let* ((consp (consp cthing))
272             (ccode (cadr cc))
273             (val (if (eq ccode :eq) (not (not consp)) (not consp))))
274        (setf (car w) (if val (%nx1-operator t) (%nx1-operator nil))
275              (cdr w) nil)))))
276
277(def-acode-rewrite acode-rewrite-cons cons type-cons (x y)
278  (rewrite-acode-form x t)
279  (rewrite-acode-form y t)
280  (acode-type-merge type-cons 'cons))
281
282(def-acode-rewrite acode-rewrite-rplacx (%rplaca %rplacd rplaca rplacd) type-cons (cell val)
283  (rewrite-acode-form cell t)
284  (rewrite-acode-form val t)
285  (acode-type-merge type-cons 'cons))
286
287(def-acode-rewrite acode-rewrite-set-cxr (set-car set-cdr) type-cons (cell val)
288  (rewrite-acode-form cell t)
289  (rewrite-acode-form val t)
290  (acode-type-merge type-cons (acode-form-type val *acode-rewrite-trust-declarations*)))
291
292(def-acode-rewrite acode-rewrite-cxr (%car %cdr car cdr) type-cons (cell)
293  (rewrite-acode-form cell t))
294
295(def-acode-rewrite acode-rewrite-vector vector type-cons (arglist)
296  (dolist (f arglist) (rewrite-acode-form f t))
297  (acode-type-merge type-cons 'simple-vector))
298
299                   
300(def-acode-rewrite acode-rewrite-%gvector %gvector type-cons (arglist)
301  (let* ((all-args (append (car arglist) (reverse (cadr arglist)))))
302    (dolist (arg all-args)
303      (rewrite-acode-form arg t))
304    ;; Could try to map constant subtag to type here
305    ))
306
307(def-acode-rewrite acode-rewrite-char-code (%char-code char-code) type-cons (&whole w c)
308  (rewrite-acode-form c t)
309  (let* ((char (acode-constant-p c)))
310    (when char
311      (let* ((code (char-code char)))
312        (setf (car w) (%nx1-operator fixnum)
313              (cadr w) code
314              (cddr w) nil)))
315    (acode-type-merge type-cons 'valid-char-code)))
316
317(def-acode-rewrite acode-rewrite-%ilogior2 %ilogior2 type-cons (&whole w x y) 
318  (acode-constant-fold-numeric-binop type-cons w x y 'logior)
319  (acode-type-merge type-cons `(or ,(acode-form-type x *acode-rewrite-trust-declarations*) ,(acode-form-type y *acode-rewrite-trust-declarations*))))
320
321(def-acode-rewrite acode-rewrite-%ilogand2 %ilogand2 type-cons (&whole w x y) 
322  (acode-constant-fold-numeric-binop type-cons w x y 'logand)
323  (acode-type-merge type-cons `(and ,(acode-form-type x *acode-rewrite-trust-declarations*) ,(acode-form-type y *acode-rewrite-trust-declarations*))))
324
325(def-acode-rewrite acode-rewrite-%ilogxor %ilogxor2 type-cons (&whole w x y) 
326  (acode-constant-fold-numeric-binop type-cons w x y 'logxor))
327   
328(def-acode-rewrite acode-rewrite-%ineg %ineg type-cons (&whole w x)
329  (rewrite-acode-form x 'fixnum)
330  (let* ((val (acode-fixnum-form-p x))
331         (negated (if val (- val))))
332    (if negated
333      (setf (acode-operator w) (if (typep negated *nx-target-fixnum-type*)
334                                 (%nx1-operator fixnum)
335                                 (%nx1-operator immediate))
336            (cadr w) negated
337            (cddr w) nil))))
338
339           
340     
341   
342   
343       
344       
Note: See TracBrowser for help on using the repository browser.