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

Last change on this file since 13249 was 13249, checked in by gb, 10 years ago

NX2-CONSTANT-INDEX-OK-FOR-TYPE-KEYWORD: returns T iff a fixnum constant
is a valid uvector index for a uvector of the type described by
a type keyword. (On x86, that mostly means that the scaled index fits
in 31 bits.)

File size: 11.5 KB
RevLine 
[11367]1;;;-*-Mode: LISP; Package: ccl -*-
2;;;
[13067]3;;;   Copyright (C) 2008-2009 Clozure Associates and contributors
[13066]4;;;   This file is part of Clozure CL. 
[11367]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
[11367]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
[11367]10;;;   conflict, the preamble takes precedence. 
11;;;
[13066]12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
[11367]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
[11386]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))
[12039]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)))
[12044]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))))
[12060]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)))))))
[12044]227    entries))
[12861]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)))))))
[13143]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)
[13249]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)))))
Note: See TracBrowser for help on using the repository browser.