source: branches/working-0711/ccl/compiler/nx2.lisp @ 13332

Last change on this file since 13332 was 13332, checked in by gz, 10 years ago

Improved compilation for some fixnum operations, %svref (r13247-r13253 from trunk)

File size: 11.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)))))
Note: See TracBrowser for help on using the repository browser.