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

Last change on this file since 15706 was 14727, checked in by gb, 8 years ago

Move ACODE-CONSTANT-P from acode-rewrite.lisp to nx2.lisp, since the
former file isn't loaded in trunk images.

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