source: trunk/source/compiler/nx2.lisp @ 14336

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

BACKEND-USE-OPERATOR ("portable" way to do X862-USE-OPERATOR,
ARM-USE-OPERATOR, etc.)

Replicate most/all of the cases that NX1-ASH tries to handle in
(allegedly portable) ACODE-OPTIMIZE-ASH. (The backends need to
maintain something like *NX-FORM-TYPE* to catch some cases, but
we do catch some things here that the frontend misses.)

File size: 16.5 KB
Line 
1;;;-*-Mode: LISP; Package: ccl -*-
2;;;
3;;;   Copyright (C) 2008-2009 Clozure Associates and contributors
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;;; Shared compiler backend utilities and infrastructure.
18
19(in-package "CCL")
20
21
22(defun nx2-bigger-cdr-than (x y)
23  (declare (cons x y))
24  (> (the fixnum (cdr x)) (the fixnum (cdr y))))
25
26;;; Return an unordered list of "varsets": each var in a varset can be
27;;; assigned a register and all vars in a varset can be assigned the
28;;; same register (e.g., no scope conflicts.)
29
30(defun nx2-partition-vars (vars inherited-vars)
31  (labels ((var-weight (var)
32             (let* ((bits (nx-var-bits var)))
33               (declare (fixnum bits))
34               (if (eql 0 (logand bits (logior
35                                        (ash 1 $vbitpuntable)
36                                        (ash -1 $vbitspecial)
37                                        (ash 1 $vbitnoreg))))
38                 (if (eql (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))
39                          (logand bits (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))))
40                   0
41                   (var-refs var))
42                 0)))
43           (sum-weights (varlist) 
44             (let ((sum 0))
45               (dolist (v varlist sum) (incf sum (var-weight v)))))
46           (vars-disjoint-p (v1 v2)
47             (if (eq v1 v2)
48               nil
49               (if (memq v1 (var-binding-info v2))
50                 nil
51                 (if (memq v2 (var-binding-info v1))
52                   nil
53                   t)))))
54    (dolist (iv inherited-vars)
55      (dolist (v vars) (push iv (var-binding-info v)))
56      (push iv vars))
57    (setq vars (%sort-list-no-key
58                ;;(delete-if #'(lambda (v) (eql (var-weight v) 0)) vars)
59                (do* ((handle (cons nil vars))
60                      (splice handle))
61                     ((null (cdr splice)) (cdr handle))                 
62                  (declare (dynamic-extent handle) (type cons handle splice))
63                  (if (eql 0 (var-weight (%car (cdr splice))))
64                    (rplacd splice (%cdr (cdr splice)))
65                    (setq splice (cdr splice))))
66                #'(lambda (v1 v2) (%i> (var-weight v1) (var-weight v2)))))
67    ;; This isn't optimal.  It partitions all register-allocatable
68    ;; variables into sets such that 1) no variable is a member of
69    ;; more than one set and 2) all variables in a given set are
70    ;; disjoint from each other A set might have exactly one member.
71    ;; If a register is allocated for any member of a set, it's
72    ;; allocated for all members of that set.
73    (let* ((varsets nil))
74      (do* ((all vars (cdr all)))
75           ((null all))
76        (let* ((var (car all)))
77          (when (dolist (already varsets t)
78                  (when (memq var (car already)) (return)))
79            (let* ((varset (cons var nil)))
80              (dolist (v (cdr all))
81                (when (dolist (already varsets t)
82                        (when (memq v (car already)) (return)))
83                  (when (dolist (d varset t)
84                          (unless (vars-disjoint-p v d) (return)))
85                    (push v varset))))
86              (let* ((weight (sum-weights varset)))
87                (declare (fixnum weight))
88                (if (>= weight 3)
89                  (push (cons (nreverse varset) weight) varsets)))))))
90      varsets)))
91
92;;; Maybe globally allocate registers to symbols naming functions & variables,
93;;; and to simple lexical variables.
94(defun nx2-allocate-global-registers (fcells vcells all-vars inherited-vars nvrs)
95  (if (null nvrs)
96    (progn
97      (dolist (c fcells) (%rplacd c nil))
98      (dolist (c vcells) (%rplacd c nil))
99      (values 0 nil))
100    (let* ((maybe (nx2-partition-vars all-vars inherited-vars)))
101      (dolist (c fcells) 
102        (if (>= (the fixnum (cdr c)) 3) (push c maybe)))
103      (dolist (c vcells) 
104        (if (>= (the fixnum (cdr c)) 3) (push c maybe)))
105      (do* ((things (%sort-list-no-key maybe #'nx2-bigger-cdr-than) (cdr things))
106            (n 0 (1+ n))
107            (registers nvrs)
108            (regno (pop registers) (pop registers))
109            (constant-alist ()))
110           ((or (null things) (null regno))
111            (dolist (cell fcells) (%rplacd cell nil))
112            (dolist (cell vcells) (%rplacd cell nil))
113            (values n constant-alist))
114        (declare (list things)
115                 (fixnum n regno))
116        (let* ((thing (car things)))
117          (if (or (memq thing fcells)
118                  (memq thing vcells))
119            (push (cons thing regno) constant-alist)
120            (dolist (var (car thing))
121              (setf (var-nvr var) regno))))))))
122
123(defun nx2-assign-register-var (v)
124  (var-nvr v))
125
126
127(defun nx2-constant-form-p (form)
128  (setq form (nx-untyped-form form))
129  (if form
130    (or (nx-null form)
131        (nx-t form)
132        (and (consp form)
133             (or (eq (acode-operator form) (%nx1-operator immediate))
134                 (eq (acode-operator form) (%nx1-operator fixnum))
135                 (eq (acode-operator form) (%nx1-operator simple-function)))))))
136
137(defun nx2-lexical-reference-p (form)
138  (when (acode-p form)
139    (let ((op (acode-operator (setq form (acode-unwrapped-form-value form)))))
140      (when (or (eq op (%nx1-operator lexical-reference))
141                (eq op (%nx1-operator inherited-arg)))
142        (%cadr form)))))
143
144;;; Returns true iff lexical variable VAR isn't setq'ed in FORM.
145;;; Punts a lot ...
146(defun nx2-var-not-set-by-form-p (var form)
147  (let* ((bits (nx-var-bits var)))
148    (or (not (%ilogbitp $vbitsetq bits))
149        (nx2-setqed-var-not-set-by-form-p var form (logbitp $vbitclosed bits)))))
150
151(defun nx2-setqed-var-not-set-by-form-p (var form &optional closed)
152  (setq form (acode-unwrapped-form form))
153  (or (atom form)
154      (nx2-constant-form-p form)
155      (nx2-lexical-reference-p form)
156      (let ((op (acode-operator form))
157            (subforms nil))
158        (if (eq op (%nx1-operator setq-lexical))
159          (and (neq var (cadr form))
160               (nx2-setqed-var-not-set-by-form-p var (caddr form)))
161          (and (or (not closed)
162                   (logbitp operator-side-effect-free-bit op))
163               (flet ((not-set-in-formlist (formlist)
164                        (dolist (subform formlist t)
165                          (unless (nx2-setqed-var-not-set-by-form-p var subform closed) (return)))))
166                 (if
167                   (cond ((%ilogbitp operator-acode-subforms-bit op) (setq subforms (%cdr form)))
168                         ((%ilogbitp operator-acode-list-bit op) (setq subforms (cadr form))))
169                   (not-set-in-formlist subforms)
170                   (and (or (eq op (%nx1-operator call))
171                            (eq op (%nx1-operator lexical-function-call)))
172                        (nx2-setqed-var-not-set-by-form-p var (cadr form))
173                        (setq subforms (caddr form))
174                        (not-set-in-formlist (car subforms))
175                        (not-set-in-formlist (cadr subforms))))))))))
176
177(defun nx2-node-gpr-p (reg)
178  (and reg
179       (eql (hard-regspec-class reg) hard-reg-class-gpr)
180       (eql (get-regspec-mode reg) hard-reg-class-gpr-mode-node)))
181
182;;; ENTRIES is a list of recorded-symbol entries, built by pushing
183;;; info for each variable referenced by the function AFUNC as it
184;;; comes into scope.  (Inherited variables "come into scope" before
185;;; anything else, then required arguments, etc.)  Supplied-p variables
186;;; may come into scope before "real" arglist entries do, which confuses
187;;; functions that try to construct a function's arglist from the symbol
188;;; map.  I -think- that confusion only exists when supplied-p variables
189;;; are involved, so this returns its first argument unless they are;
190;;; otherwise, it ensures that all toplevel arglist symbols are followed
191;;; only by any inherited variables, and that the arglist symbols are
192;;; in the correct (reversed) order
193(defun nx2-recorded-symbols-in-arglist-order (entries afunc)
194  (let* ((alambda (afunc-acode afunc)))
195    (when (and (acode-p alambda)
196               (eq (acode-operator alambda) (%nx1-operator lambda-list)))
197      (destructuring-bind (req opt rest keys &rest ignore) (cdr alambda)
198        (declare (ignore ignore))
199        (when (or (dolist (sp (caddr opt))
200                    (when sp (return t)))
201                  (dolist (sp (caddr keys))
202                    (when sp (return t))))
203          (let* ((new ()))
204            (flet ((info-for-var (var)
205                     (assoc var entries :test #'eq)))
206              (flet ((add-new-info (var)
207                       (let* ((info (info-for-var var)))
208                         (when info
209                           (push info new)))))
210                (setq entries (nreverse entries))
211                (dolist (var (afunc-inherited-vars afunc))
212                  (add-new-info var))
213                (dolist (r req)
214                  (add-new-info r))
215                (dolist (o (car opt))
216                  (add-new-info o))
217                (when (consp rest)
218                  (setq rest (car rest)))
219                (when rest
220                  (add-new-info rest))
221                (dolist (k (cadr keys))
222                  (add-new-info k))
223                (dolist (e entries)
224                  (unless (member e new :test #'eq)
225                    (push e new)))
226                (setq entries new)))))))
227    entries))
228
229(defun nx2-replace-var-refs (var value)
230  (when (acode-p value)
231    (let* ((op (acode-operator value))
232           (operands (acode-operands value)))
233      (when (typep op 'fixnum)
234        (dolist (ref (var-ref-forms var) (setf (var-ref-forms var) nil))
235          (when (acode-p ref)
236            (setf (acode-operator ref) op
237                  (acode-operands ref) operands)))))))
238
239(defun acode-immediate-operand (x)
240  (let* ((x (acode-unwrapped-form x)))
241    (if (eq (acode-operator x) (%nx1-operator immediate))
242      (cadr x)
243      (compiler-bug "not an immediate: ~s" x))))
244
245(defun nx2-constant-index-ok-for-type-keyword (idx keyword)
246  (when (>= idx 0)
247    (let* ((arch (backend-target-arch *target-backend*))
248           (limit
249            (case keyword
250              ((:bignum 
251                :single-float 
252                :double-float 
253                :xcode-vector
254                :signed-32-bit-vector 
255                :unsigned-32-bit-vector 
256                :single-float-vector 
257                :simple-string)
258               (arch::target-max-32-bit-constant-index arch))
259              (:bit-vector (arch::target-max-1-bit-constant-index arch))
260              ((:signed-8-bit-vector :unsigned-8-bit-vector)
261               (arch::target-max-8-bit-constant-index arch))
262              ((:signed-16-bit-vector :unsigned-16-bit-vector)
263               (arch::target-max-16-bit-constant-index arch))
264              ((:signed-64-bit-vector 
265                :unsigned-64-bit-vector 
266                :double-float-vector)
267               (arch::target-max-64-bit-constant-index arch))
268              (t
269               ;; :fixnum or node
270               (target-word-size-case
271                (32 (arch::target-max-32-bit-constant-index arch))
272                (64 (arch::target-max-64-bit-constant-index arch)))))))
273      (and limit (< idx limit)))))
274
275(defun backend-use-operator (op seg vreg xfer &rest forms)
276  (declare (dynamic-extent forms))
277  (apply (svref (backend-p2-dispatch *target-backend*)
278                (%ilogand op operator-id-mask))
279         seg vreg xfer forms))
280
281;;; Return non-nil iff we can do something better than a subprim call
282;;; to .SPbuiltin-ash.
283(defun acode-optimize-ash (seg vreg xfer num amt trust-decls &optional (result-type 'integer))
284  (let* ((unsigned-natural-type (target-word-size-case
285                                 (32 '(unsigned-byte 32))
286                                 (64 '(unsigned-byte 64))))
287         (target-fixnum-type (target-word-size-case
288                              (32 '(signed-byte 30))
289                              (64 '(signed-byte 61))))
290         (max (target-word-size-case (32 32) (64 64)))
291         (maxbits (target-word-size-case
292                   (32 29)
293                   (64 60)))
294         (const-num (acode-integer-form-p num))
295         (const-amt (acode-integer-form-p amt))
296         (shifted (and const-num const-amt (ash const-num const-amt))))
297    (cond (shifted
298           (if (nx1-target-fixnump shifted)
299             (backend-use-operator (%nx1-operator fixnum) seg vreg xfer shifted)
300             (backend-use-operator (%nx1-operator immediate) seg vreg xfer shifted))
301           t)
302          ((eql const-amt 0)
303           (backend-use-operator (%nx1-operator require-integer) seg vreg xfer num)
304           t)
305          ((and (fixnump const-amt) (< const-amt 0))
306           (if (acode-form-typep num target-fixnum-type trust-decls)
307             (progn
308               (backend-use-operator (%nx1-operator %iasr)
309                                     seg
310                                     vreg
311                                     xfer
312                                     (make-acode (%nx1-operator fixnum)
313                                                 (- const-amt))
314                                     num)
315               t)
316             (if (acode-form-typep num unsigned-natural-type trust-decls)
317               (progn
318                 (if (< (- const-amt) max)
319                   (backend-use-operator (%nx1-operator natural-shift-right)
320                                         seg
321                                         vreg
322                                         xfer
323                                         num
324                                         (make-acode (%nx1-operator fixnum)
325                                                   (- const-amt)))
326                   (progn
327                     (backend-use-operator (%nx1-operator require-fixnum)
328                                           seg
329                                           nil
330                                           nil
331                                           num)
332                     (backend-use-operator (%nx1-operator fixnum)
333                                           seg
334                                           vreg
335                                           xfer
336                                           0)))
337                 t))))
338          ((and (fixnump const-amt)
339                (<= 0 const-amt maxbits)
340                (or (acode-form-typep num `(signed-byte ,(- (1+ maxbits) const-amt)) trust-decls)
341                      (and (acode-form-typep num 'fixnum trust-decls)
342                           trust-decls
343                           (subtypep result-type 'fixnum))))
344           (progn
345             (backend-use-operator (%nx1-operator %ilsl)
346                                   seg
347                                   vreg
348                                   xfer
349                                   (make-acode (%nx1-operator fixnum)
350                                               const-amt)
351                                   num)
352             t))
353          ((and (fixnump const-amt)
354                (< 0 const-amt max)
355                (acode-form-typep num unsigned-natural-type trust-decls)
356                trust-decls
357                (subtypep result-type unsigned-natural-type))
358           (backend-use-operator (%nx1-operator natural-shift-left)
359                                 seg
360                                 vreg
361                                 xfer
362                                 num
363                                 amt)
364           t)
365          ((typep const-num target-fixnum-type)
366           (let* ((field-width (1+ (integer-length const-num)))
367                    ;; num fits in a `(signed-byte ,field-width)
368                    (max-shift (- (1+ maxbits) field-width)))
369               (when (acode-form-typep amt `(mod ,(1+ max-shift)) trust-decls)
370                 (backend-use-operator (%nx1-operator %ilsl)
371                                       seg
372                                       vreg
373                                       xfer
374                                       amt
375                                       (make-acode (%nx1-operator fixnum)
376                                                   const-num))
377                 t)))
378          (t nil))))
379         
380                   
381                 
382               
Note: See TracBrowser for help on using the repository browser.