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

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

systems.lisp, compile-ccl.lisp, l1-boot-2.lisp: Compile and load
ACODE-REWRITE.

acode-rewrite.lisp: new, improved ... still not working, still not
complete.

nx.lisp: COMPILE-NAMED-FUNCTION optionally rewrites acode after generating
it (under control of *NX-REWRITE-ACODE*, for now.)

File size: 11.9 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;(next-nx-defops)
30(defvar *acode-rewrite-functions* nil)
31(let* ((newsize (%i+ (next-nx-num-ops) 10))
32       (old *acode-rewrite-functions*)
33       (oldsize (length old)))
34  (declare (fixnum newsize oldsize))
35  (unless (>= oldsize newsize)
36    (let* ((v (make-array newsize :initial-element nil)))
37      (dotimes (i oldsize (setq *acode-rewrite-functions* v))
38        (setf (svref v i) (svref old i))))))
39
40(eval-when (:compile-toplevel :load-toplevel :execute)
41  (defmacro def-acode-rewrite (name operator-list typecons arglist &body body)
42    (if (atom operator-list)
43      (setq operator-list (list operator-list)))
44    (multiple-value-bind (lambda-list whole)
45        (normalize-lambda-list arglist t)
46      (multiple-value-bind (body decls)
47          (parse-body body nil t)
48        (collect ((let-body))
49          (dolist (operator operator-list)
50            (let-body `(setf (svref *acode-rewrite-functions* (logand operator-id-mask (%nx1-operator ,operator))) fun)))
51          (let* ((whole-var (gensym "WHOLE")))
52            (multiple-value-bind (bindings binding-decls)
53                (%destructure-lambda-list lambda-list whole-var nil nil
54                                          :cdr-p t
55                                          :whole-p nil
56                                          :use-whole-var t
57                                          :default-initial-value nil)
58              (when whole
59                (setq bindings (nconc bindings (list `(,whole ,whole-var)))))
60             
61        `(let* ((fun (nfunction ,name 
62                                (lambda (,typecons ,whole-var)
63                                  (declare (ignorable ,typecons))
64                                  (block ,name
65                                    (let* ,(nreverse bindings)
66                                      ,@(when binding-decls `((declare ,@binding-decls)))
67                                      ,@decls
68                                      ,@body))))))
69          ,@(let-body)))))))))
70
71;;; Don't walk the form (that's already happened.)
72(defun acode-post-form-type (form)
73  (when (acode-p form)
74    (let* ((op (acode-operator form))
75           (operands (cdr form)))
76      (cond ((and *acode-rewrite-trust-declarations*
77                  (eq op (%nx1-operator typed-form)))
78             (acode-operand 0 operands))
79            ((eq op (%nx1-operator fixnum))
80             'fixnum)
81            ((eq op (%nx1-operator immediate))
82             (type-of (acode-operand 0 operands)))
83            (t t)))))
84
85(defun acode-constant-p (form)
86  ;; This returns (values constant-value constantp); some code
87  ;; may need to check constantp if constant-value is nil.
88  (let* ((form (acode-unwrapped-form-value form))
89         (op (if (acode-p form) (acode-operator form))))
90    (cond ((eql op (%nx1-operator nil))
91           (values nil t))
92          ((eql op (%nx1-operator t))
93           (values t t))
94          ((or (eql op (%nx1-operator fixnum))
95               (eql op (%nx1-operator immediate)))
96           (values (cadr form) t))
97          (t (values nil nil)))))
98
99
100(defun acode-post-form-typep (form type)
101  (let* ((ctype (specifier-type type))
102         (form (acode-unwrapped-form-value form)))
103    (cond ((nx-null form) (ctypep nil ctype))
104          ((nx-t form) (ctypep t ctype))
105          ((not (acode-p form)) (values nil nil))
106          (t
107           (let* ((op (acode-operator form))
108                  (operands (cdr form)))
109             (cond ((and *acode-rewrite-trust-declarations*
110                         (eq op (%nx1-operator typed-form)))
111                    (subtypep (acode-operand 0 operands) type))
112                   ((or (eq op (%nx1-operator fixnum))
113                        (eq op (%nx1-operator immediate)))
114                    (ctypep (acode-operand 0 operands) (specifier-type type)))
115                   (t (values nil nil))))))))
116
117(defun rewrite-acode-form (form type)
118  (when (acode-p form)
119    (let* ((op (acode-operator form))
120           (rest (acode-operands form))
121           (rewrite (svref *acode-rewrite-functions* (logand op operator-id-mask))))
122      (when rewrite
123        (let* ((new (cons op rest))
124               (type-cons (list type new)))
125          (setf (car form) (%nx1-operator type-asserted-form)
126                (cdr form) type-cons)
127          (funcall rewrite type-cons new))))))
128     
129   
130
131(defun acode-constant-fold-numeric-binop (type-cons whole form1 form2 function)
132  (rewrite-acode-form form1 t)
133  (rewrite-acode-form form2 t)
134  (let* ((v1 (acode-xxx-form-p form1 'number))
135         (v2 (acode-xxx-form-p form2 'number))
136         (val (and v1 v2 (ignore-errors (funcall function v1 v2)))))
137    (when val
138      (setf (car whole) (if (typep val *nx-target-fixnum-type*)
139                          (%nx1-operator fixnum)
140                          (%nx1-operator immediate))
141            (cadr whole) val
142            (cddr whole) nil
143            (car type-cons) (if (typep val 'integer)
144                             `(integer ,val ,val)
145                             (type-of val)))
146      val)))
147
148(defun acode-rewrite-decls (decls)
149  (if (fixnump decls)
150    (locally (declare (fixnum decls))
151      (setq *acode-rewrite-tail-allow* (neq 0 (%ilogand2 $decl_tailcalls decls))
152            *acode-rewrite-open-code-inline* (neq 0 (%ilogand2 $decl_opencodeinline decls))
153            *acode-rewrite-full-safety* (neq 0 (%ilogand2 $decl_full_safety decls))
154            *acode-rewrite-reckless* (neq 0 (%ilogand2 $decl_unsafe decls))
155            *acode-rewrite-trust-declarations* (neq 0 (%ilogand2 $decl_trustdecls decls))))))
156
157(defmacro with-acode-declarations (declsform &body body)
158  `(let* ((*acode-rewrite-tail-allow* *acode-rewrite-tail-allow*)
159          (*acode-rewrite-reckless* *acode-rewrite-reckless*)
160          (*acode-rewrite-open-code-inline* *acode-rewrite-open-code-inline*)
161          (*acode-rewrite-trust-declarations* *acode-rewrite-trust-declarations*)
162          (*acode-rewrite-full-safety* *acode-rewrite-full-safety*))
163     (acode-rewrite-decls ,declsform)
164     ,@body))
165
166(defun acode-maybe-punt-var (var initform)
167  (let* ((bits (nx-var-bits var)))
168    (declare (fixnum bits))
169    (cond ((and (logbitp $vbitpuntable var)
170                (not (logbitp $vbitpunted var)))
171           (nx-set-var-bits var (logior (ash 1 $vbitpunted) bits))
172           (rewrite-acode-form initform (or (var-inittype var) t))
173           (nx2-replace-var-refs var initform)
174           (setf (var-ea var) initform))
175          (t
176           (rewrite-acode-form initform t)))))
177           
178(defun acode-type-merge (type-cons derived)
179  (let* ((asserted (car type-cons))
180         (intersection (ignore-errors (type-specifier (specifier-type `(and ,asserted ,derived))))))
181    (when intersection
182      (setf (car type-cons) intersection))))
183
184         
185   
186 
187
188(def-acode-rewrite acode-rewrite-lambda lambda-list type-cons (req opt rest keys auxen body p2-decls &optional code-note)
189  (declare (ignore code-note req rest))
190  (with-acode-declarations p2-decls
191    (dolist (optinit (cadr opt))
192      (rewrite-acode-form optinit t))
193    (dolist (keyinit (nth 3 keys))
194      (rewrite-acode-form keyinit t))
195    (do* ((auxvars (car auxen) (cdr auxvars))
196          (auxvals (cadr auxen) (cdr auxvals)))
197         ((null auxvars))
198      (acode-maybe-punt-var (car auxvars) (car auxvals)))
199    (rewrite-acode-form body (car type-cons))
200    (acode-type-merge type-cons (acode-form-type body *acode-rewrite-trust-declarations*))))
201
202(def-acode-rewrite acode-rewrite-progn progn type-cons (&rest forms)
203  (do* ((form (pop forms) (pop forms)))
204       ((null forms))
205    (if forms
206      (rewrite-acode-form form t)
207      (progn
208        (rewrite-acode-form form (car type-cons))
209        (acode-type-merge type-cons (acode-form-type form *acode-rewrite-trust-declarations*))))))
210
211(def-acode-rewrite acode-rewrite-prog1 prog1 type-cons (first &rest others)
212  (rewrite-acode-form first (car type-cons))
213  (dolist (other others) (rewrite-acode-form other t))
214  (acode-type-merge type-cons (acode-form-type first *acode-rewrite-trust-declarations*)))
215
216(def-acode-rewrite acode-rewrite-%slot-ref %slot-ref type-cons (instance idx)
217  (rewrite-acode-form instance t)
218  (rewrite-acode-form idx t))
219
220(def-acode-rewrite acode-rewrite-svref (%svref svref) type-cons (&whole w vector idx)
221  (rewrite-acode-form vector t)
222  (rewrite-acode-form idx t)
223  (let* ((cv (acode-constant-p vector)))
224    (when (if (eql (car w) (%nx1-operator svref))
225            (typep cv 'simple-vector)
226            (gvectorp cv))
227      (let* ((cidx (acode-fixnum-form-p idx)))
228        (when (and (typep cidx 'fixnum)
229                   (>= (the fixnum cidx) 0)
230                   (< (the fixnum cidx) (the fixnum (uvsize cv))))
231          (let* ((val (%svref cv cidx)))
232            (setf (car w) (if (nx1-target-fixnump val)
233                            (%nx1-operator fixnum)
234                            (%nx1-operator immediate))
235                  (cadr w) val
236                  (cddr w) nil)
237            (acode-type-merge type-cons (type-of val))))))))
238
239(def-acode-rewrite acode-rewrite-%sbchar %sbchar type-cons (&whole w string idx)
240  (rewrite-acode-form string t)
241  (rewrite-acode-form idx t)
242  (let* ((cv (acode-constant-p string)))
243    (when (typep cv 'simple-string)
244      (let* ((cidx (acode-fixnum-form-p idx)))
245        (when (and (typep cidx 'fixnum)
246                   (>= (the fixnum cidx) 0)
247                   (< (the fixnum cidx) (the fixnum (length cv))))
248          (let* ((val (%schar cv cidx)))
249            (setf (car w) (%nx1-operator immediate)
250                  (cadr w) val
251                  (cddr w) nil)
252            (acode-type-merge type-cons 'character)))))))
253
254(def-acode-rewrite acode-rewrite-svset (%svset svset) type-cons (vector idx value)
255  (rewrite-acode-form vector t)
256  (rewrite-acode-form idx t)
257  (rewrite-acode-form value (car type-cons))
258  (acode-type-merge type-cons (acode-form-type value *acode-rewrite-trust-declarations*)))
259
260(def-acode-rewrite acode-rewrite-consp consp type-cons (&whole w cc thing)
261  (rewrite-acode-form thing t)
262  (multiple-value-bind (cthing constantp) (acode-constant-p thing)
263    (if constantp
264      (let* ((consp (consp cthing))
265             (ccode (cadr cc))
266             (val (if (eq ccode :eq) (not (not consp)) (not consp))))
267        (setf (car w) (if val (%nx1-operator t) (%nx1-operator nil))
268              (cdr w) nil)))))
269
270(def-acode-rewrite acode-rewrite-cons cons type-cons (x y)
271  (rewrite-acode-form x t)
272  (rewrite-acode-form y t)
273  (acode-type-merge type-cons 'cons))
274
275(def-acode-rewrite acode-rewrite-rplacx (%rplaca %rplacd rplaca rplacd) type-cons (cell val)
276  (rewrite-acode-form cell t)
277  (rewrite-acode-form val t)
278  (acode-type-merge type-cons 'cons))
279
280(def-acode-rewrite acode-rewrite-set-cxr (set-car set-cdr) type-cons (cell val)
281  (rewrite-acode-form cell t)
282  (rewrite-acode-form val t)
283  (acode-type-merge type-cons (acode-form-type val *acode-rewrite-trust-declarations*)))
284
285(def-acode-rewrite acode-rewrite-cxr (%car %cdr car cdr) type-cons (cell)
286  (rewrite-acode-form cell t))
287
288(def-acode-rewrite acode-rewrite-vector vector type-cons (arglist)
289  (dolist (f arglist) (rewrite-acode-form f t))
290  (acode-type-merge type-cons 'simple-vector))
291
292                   
293       
294       
Note: See TracBrowser for help on using the repository browser.