source: trunk/source/compiler/nx2.lisp

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

File size: 22.7 KB
Line 
1;;;-*-Mode: LISP; Package: ccl -*-
2;;;
3;;; Copyright 2008-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
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  (> (cdr x) (cdr y)))
25
26
27;;; Return an unordered list of "varsets": each var in a varset can be
28;;; assigned a register and all vars in a varset can be assigned the
29;;; same register (e.g., no scope conflicts.)
30
31(defun nx2-partition-vars (vars inherited-vars &optional (afunc-flags 0))
32  (labels ((var-weight (var)
33             (let* ((bits (nx-var-bits var)))
34               (declare (fixnum bits))
35               (if (eql 0 (logand bits (logior
36                                        (ash 1 $vbitpuntable)
37                                        (ash -1 $vbitspecial)
38                                        (ash 1 $vbitnoreg))))
39                 (if (or (var-nvr var)  ; already assiged a register via other means
40                         (eql (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))
41                              (logand bits (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq)))))
42                   0
43                   (let* ((w (var-refs var)))
44                     (if (logbitp $fbittailcallsself afunc-flags)
45                       (ash w 2)
46                       w)))
47                 0)))
48           (sum-weights (varlist) 
49             (let ((sum 0))
50               (dolist (v varlist sum) (incf sum (var-weight v)))))
51           (vars-disjoint-p (v1 v2)
52             (if (eq v1 v2)
53               nil
54               (if (memq v1 (var-binding-info v2))
55                 nil
56                 (if (memq v2 (var-binding-info v1))
57                   nil
58                   t)))))
59    (dolist (iv inherited-vars)
60      (dolist (v vars) (pushnew iv (var-binding-info v) :test #'eq))
61      (push iv vars))
62    (setq vars (%sort-list-no-key
63                ;;(delete-if #'(lambda (v) (eql (var-weight v) 0)) vars)
64                (do* ((handle (cons nil vars))
65                      (splice handle))
66                     ((null (cdr splice)) (cdr handle))                 
67                  (declare (dynamic-extent handle) (type cons handle splice))
68                  (if (eql 0 (var-weight (%car (cdr splice))))
69                    (rplacd splice (%cdr (cdr splice)))
70                    (setq splice (cdr splice))))
71                #'(lambda (v1 v2) (%i> (var-weight v1) (var-weight v2)))))
72    ;; This isn't optimal.  It partitions all register-allocatable
73    ;; variables into sets such that 1) no variable is a member of
74    ;; more than one set and 2) all variables in a given set are
75    ;; disjoint from each other A set might have exactly one member.
76    ;; If a register is allocated for any member of a set, it's
77    ;; allocated for all members of that set.
78    (let* ((varsets nil))
79      (do* ((all vars (cdr all)))
80           ((null all))
81        (let* ((var (car all)))
82          (when (dolist (already varsets t)
83                  (when (memq var (car already)) (return)))
84            (let* ((varset (cons var nil)))
85              (dolist (v (cdr all))
86                (when (dolist (already varsets t)
87                        (when (memq v (car already)) (return)))
88                  (when (dolist (d varset t)
89                          (unless (vars-disjoint-p v d) (return)))
90                    (push v varset))))
91              (let* ((weight (sum-weights varset)))
92                (declare (fixnum weight))
93                (if (>= weight 3)
94                  (push (cons (nreverse varset) weight) varsets)))))))
95      varsets)))
96
97;;; Maybe globally allocate registers to symbols naming functions & variables,
98;;; and to simple lexical variables.
99(defun nx2-afunc-allocate-global-registers (afunc nvrs)
100  (let* ((vcells (afunc-vcells afunc))
101         (fcells (afunc-fcells afunc))
102         (all-vars (afunc-all-vars afunc))
103         (inherited-vars (afunc-inherited-vars afunc)))
104    (if (null nvrs)
105      (progn
106        (dolist (c fcells) (%rplacd c nil))
107        (dolist (c vcells) (%rplacd c nil))
108        (values 0 nil))
109      (let* ((maybe (nx2-partition-vars
110                     all-vars
111                     inherited-vars
112                     (afunc-bits afunc))))
113        (dolist (c fcells) 
114          (if (>= (the fixnum (cdr c)) 3) (push c maybe)))
115        (dolist (c vcells) 
116          (if (>= (the fixnum (cdr c)) 3) (push c maybe)))
117        (do* ((things (%sort-list-no-key maybe #'nx2-bigger-cdr-than) (cdr things))
118              (n 0 (1+ n))
119              (registers nvrs)
120              (regno (pop registers) (pop registers))
121              (constant-alist ()))
122             ((or (null things) (null regno))
123              (dolist (cell fcells) (%rplacd cell nil))
124              (dolist (cell vcells) (%rplacd cell nil))
125              (values n constant-alist))
126          (declare (list things)
127                   (fixnum n regno))
128          (let* ((thing (car things)))
129            (if (or (memq thing fcells)
130                    (memq thing vcells))
131              (push (cons thing regno) constant-alist)
132              (dolist (var (car thing))
133                (setf (var-nvr var) regno)))))))))
134
135(defun nx2-assign-register-var (v)
136  (var-nvr v))
137
138(defun nx2-select-fpr-candidates (vars &optional restricted)
139  (let* ((fvars ()))
140    (dolist (v vars (%sort-list-no-key (nx2-partition-vars fvars nil)
141                                       #'nx2-bigger-cdr-than))
142      (unless (member v restricted :test #'eq)
143        (let* ((bits (nx-var-bits v)))
144          (declare (fixnum bits))
145          (when (eql 0 (logand bits (logior 
146                                     (ash 1 $vbitpuntable)
147                                     (ash -1 $vbitspecial)
148                                     (ash 1 $vbitnoreg)
149                                     (ash 1 $vbitdynamicextent)
150                                     (ash 1 $vbitclosed))))
151            (if (logbitp $vbitsetq bits)
152              (setf (var-refs v) (ash (var-refs v) 2))
153              (unless (var-declared-type v)
154))
155            (let* ((type (var-declared-type v)))
156              (when (and (or (eq type 'single-float)
157                             (eq type 'double-float))
158                         (logbitp $vbitsetq bits))
159                (push v fvars)))))))))
160         
161               
162             
163
164(defun nx2-constant-form-p (form)
165  (setq form (nx-untyped-form form))
166  (if form
167    (or (nx-null form)
168        (nx-t form)
169        (and (acode-p form)
170             (or (eq (acode-operator form) (%nx1-operator immediate))
171                 (eq (acode-operator form) (%nx1-operator fixnum))
172                 (eq (acode-operator form) (%nx1-operator simple-function)))))))
173
174(defun nx2-lexical-reference-p (form)
175  (when (acode-p form)
176    (let ((op (acode-operator (setq form (acode-unwrapped-form-value form)))))
177      (when (or (eq op (%nx1-operator lexical-reference))
178                (eq op (%nx1-operator inherited-arg)))
179        (car (acode-operands form))))))
180
181(defun nx2-acode-call-p (form)
182  (when (acode-p form)
183    (let ((op (acode-operator (acode-unwrapped-form-value form))))
184      (or (eq op (%nx1-operator multiple-value-call))
185          (eq op (%nx1-operator call))
186          (eq op (%nx1-operator lexical-function-call))
187          (eq op (%nx1-operator self-call))
188          (eq op (%nx1-operator builtin-call))))))
189         
190 
191
192;;; Returns true iff lexical variable VAR isn't setq'ed in FORM.
193;;; Punts a lot ...
194(defun nx2-var-not-set-by-form-p (var form)
195  (let* ((bits (nx-var-bits var)))
196    (or (not (%ilogbitp $vbitsetq bits))
197        (nx2-setqed-var-not-set-by-form-p var form (logbitp $vbitclosed bits)))))
198
199(defun nx2-setqed-var-not-set-by-form-p (var form &optional closed)
200  (setq form (acode-unwrapped-form form))
201  (or (not (acode-p form))
202      (nx2-constant-form-p form)
203      (nx2-lexical-reference-p form)
204      (let ((op (acode-operator form))
205            (operands (acode-operands form))
206            (subforms nil))
207        (if (eq op (%nx1-operator setq-lexical))
208          (and (neq var (car operands))
209               (nx2-setqed-var-not-set-by-form-p var (cadr operands)))
210          (and (or (not closed)
211                   (logbitp operator-side-effect-free-bit op))
212               (flet ((not-set-in-formlist (formlist)
213                        (dolist (subform formlist t)
214                          (unless (nx2-setqed-var-not-set-by-form-p var subform closed) (return)))))
215                 (if
216                   (cond ((%ilogbitp operator-acode-subforms-bit op) (setq subforms operands))
217                         ((%ilogbitp operator-acode-list-bit op) (setq subforms (car operands))))
218                   (not-set-in-formlist subforms)
219                   (and (or (eq op (%nx1-operator call))
220                            (eq op (%nx1-operator lexical-function-call)))
221                        (nx2-setqed-var-not-set-by-form-p var (car operands))
222                        (setq subforms (cadr operands))
223                        (not-set-in-formlist (car subforms))
224                        (not-set-in-formlist (cadr subforms))))))))))
225
226(defun nx2-var-not-reffed-by-form-p (var form &optional closed)
227  (setq form (acode-unwrapped-form form))
228  (unless (eq var (nx2-lexical-reference-p form))
229    (or (not (acode-p form))
230        (nx2-lexical-reference-p form)  ;not us
231        (nx2-constant-form-p form)
232        (let ((op (acode-operator form))
233              (operands (acode-operands form))
234              (subforms nil))
235          (if (eq op (%nx1-operator setq-lexical))
236            (and (neq var (car operands))
237                 (nx2-var-not-reffed-by-form-p var (cadr operands)))
238            (and (or (not closed)
239                     (logbitp operator-side-effect-free-bit op))
240                 (flet ((not-reffed-in-formlist (formlist)
241                          (dolist (subform formlist t)
242                            (unless (nx2-var-not-reffed-by-form-p var subform closed) (return)))))
243                   (if
244                     (cond ((%ilogbitp operator-acode-subforms-bit op) (setq subforms operands))
245                           ((%ilogbitp operator-acode-list-bit op) (setq subforms (car operands))))
246                     (not-reffed-in-formlist subforms)
247                     (and (or (eq op (%nx1-operator call))
248                              (eq op (%nx1-operator lexical-function-call)))
249                          (nx2-var-not-reffed-by-form-p var (car operands))
250                          (setq subforms (cadr operands))
251                          (not-reffed-in-formlist (car subforms))
252                          (not-reffed-in-formlist (cadr subforms)))))))))))
253
254(defun nx2-node-gpr-p (reg)
255  (and reg
256       (eql (hard-regspec-class reg) hard-reg-class-gpr)
257       (eql (get-regspec-mode reg) hard-reg-class-gpr-mode-node)))
258
259;;; ENTRIES is a list of recorded-symbol entries, built by pushing
260;;; info for each variable referenced by the function AFUNC as it
261;;; comes into scope.  (Inherited variables "come into scope" before
262;;; anything else, then required arguments, etc.)  Supplied-p variables
263;;; may come into scope before "real" arglist entries do, which confuses
264;;; functions that try to construct a function's arglist from the symbol
265;;; map.  I -think- that confusion only exists when supplied-p variables
266;;; are involved, so this returns its first argument unless they are;
267;;; otherwise, it ensures that all toplevel arglist symbols are followed
268;;; only by any inherited variables, and that the arglist symbols are
269;;; in the correct (reversed) order
270(defun nx2-recorded-symbols-in-arglist-order (entries afunc)
271  (let* ((alambda (afunc-acode afunc)))
272    (when (and (acode-p alambda)
273               (eq (acode-operator alambda) (%nx1-operator lambda-list)))
274      (destructuring-bind (req opt rest keys &rest ignore) (acode-operands alambda)
275        (declare (ignore ignore))
276        (when (or (dolist (sp (caddr opt))
277                    (when sp (return t)))
278                  (dolist (sp (caddr keys))
279                    (when sp (return t))))
280          (let* ((new ()))
281            (flet ((info-for-var (var)
282                     (assoc var entries :test #'eq)))
283              (flet ((add-new-info (var)
284                       (let* ((info (info-for-var var)))
285                         (when info
286                           (push info new)))))
287                (setq entries (nreverse entries))
288                (dolist (var (afunc-inherited-vars afunc))
289                  (add-new-info var))
290                (dolist (r req)
291                  (add-new-info r))
292                (dolist (o (car opt))
293                  (add-new-info o))
294                (when (consp rest)
295                  (setq rest (car rest)))
296                (when rest
297                  (add-new-info rest))
298                (dolist (k (cadr keys))
299                  (add-new-info k))
300                (dolist (e entries)
301                  (unless (member e new :test #'eq)
302                    (push e new)))
303                (setq entries new)))))))
304    entries))
305
306(defun nx2-replace-var-refs (var value)
307  (when (acode-p value)
308    (let* ((op (acode-operator value))
309           (operands (acode-operands value)))
310      (when (typep op 'fixnum)
311        (dolist (ref (var-ref-forms var) (setf (var-ref-forms var) nil))
312          (when (acode-p ref)
313            (setf (acode-operator ref) op
314                  (acode-operands ref) operands)))))))
315
316(defun acode-immediate-operand (x)
317  (let* ((x (acode-unwrapped-form x)))
318    (if (eq (acode-operator x) (%nx1-operator immediate))
319      (car (acode-operands x))
320      (compiler-bug "not an immediate: ~s" x))))
321
322(defun nx2-constant-index-ok-for-type-keyword (idx keyword)
323  (when (>= idx 0)
324    (let* ((arch (backend-target-arch *target-backend*))
325           (limit
326            (case keyword
327              ((:bignum 
328                :single-float 
329                :double-float 
330                :xcode-vector
331                :signed-32-bit-vector 
332                :unsigned-32-bit-vector 
333                :single-float-vector 
334                :simple-string)
335               (arch::target-max-32-bit-constant-index arch))
336              (:bit-vector (arch::target-max-1-bit-constant-index arch))
337              ((:signed-8-bit-vector :unsigned-8-bit-vector)
338               (arch::target-max-8-bit-constant-index arch))
339              ((:signed-16-bit-vector :unsigned-16-bit-vector)
340               (arch::target-max-16-bit-constant-index arch))
341              ((:signed-64-bit-vector 
342                :unsigned-64-bit-vector 
343                :double-float-vector)
344               (arch::target-max-64-bit-constant-index arch))
345              (t
346               ;; :fixnum or node
347               (target-word-size-case
348                (32 (arch::target-max-32-bit-constant-index arch))
349                (64 (arch::target-max-64-bit-constant-index arch)))))))
350      (and limit (< idx limit)))))
351
352(defun backend-use-operator (op seg vreg xfer &rest forms)
353  (declare (dynamic-extent forms))
354  (apply (svref (backend-p2-dispatch *target-backend*)
355                (%ilogand op operator-id-mask))
356         seg vreg xfer forms))
357
358(defun backend-apply-acode (acode seg vreg xfer)
359  (apply (svref (backend-p2-dispatch *target-backend*)
360                (%ilogand (acode-operator acode) operator-id-mask))
361         seg vreg xfer (acode-operands acode)))
362
363
364
365(defun acode-constant-p (form)
366  ;; This returns (values constant-value constantp); some code
367  ;; may need to check constantp if constant-value is nil.
368  (let* ((form (acode-unwrapped-form-value form))
369         (op (if (acode-p form) (acode-operator form))))
370    (cond ((eql op (%nx1-operator nil))
371           (values nil t))
372          ((eql op (%nx1-operator t))
373           (values t t))
374          ((eql op (%nx1-operator fixnum))
375           (values (car (acode-operands form)) t))
376          ((eql op (%nx1-operator immediate))
377           ;; recognize the acode produced for LOAD-TIME-VALUE by
378           ;; COMPILE-FILE as something non-constant.
379           (if (and 
380                (consp (car (acode-operands form)))
381                *load-time-eval-token*
382                (eq (car (car (acode-operands form))) *load-time-eval-token*))
383             (values nil nil)
384                             
385                   
386             (values (car (acode-operands form)) t)))
387          (t (values nil nil)))))
388
389(defun acode-constant-fold-binop (seg vreg xfer x y function)
390  (multiple-value-bind (const-x x-p) (acode-constant-p x)
391    (when x-p
392      (multiple-value-bind (const-y y-p) (acode-constant-p y)
393        (when y-p
394          (let* ((result (ignore-errors (funcall function const-x const-y))))
395            (when result
396              (backend-use-operator (if (nx1-target-fixnump result)
397                                      (%nx1-operator fixnum)
398                                      (%nx1-operator immediate))
399                                    seg
400                                    vreg
401                                    xfer
402                                    result)
403              t)))))))
404
405
406
407
408
409
410       
411
412
413
414(defun acode-optimize-minus1 (seg vreg xfer form trust-decls &optional (result-type 'number))
415  (declare (ignorable result-type))
416  (multiple-value-bind (val constp) (acode-constant-p form)
417    (cond ((and (and constp (ignore-errors (setq val (- val)))))
418           (backend-use-operator (if (typep val *nx-target-fixnum-type*)
419                                   (%nx1-operator fixnum)
420                                   (%nx1-operator immediate))
421                                 seg vreg xfer val)
422           t)
423          ((acode-form-typep form 'double-float trust-decls)
424           (backend-use-operator (%nx1-operator %double-float-negate) seg vreg xfer form)
425           t)
426          ((acode-form-typep form 'single-float trust-decls)
427           (backend-use-operator (%nx1-operator %single-float-negate) seg vreg xfer form)
428           t)
429          ((acode-form-typep form *nx-target-fixnum-type* trust-decls)
430           (backend-use-operator (%nx1-operator %ineg) seg vreg xfer form)
431           t))))
432
433(defun nx2-is-comparison-of-var-to-fixnums (form)
434  ;; Catches some cases.  May miss some.
435  (flet ((is-simple-comparison-of-var-to-fixnum (form)
436           (let* ((var nil)
437                  (fixval nil))
438             (setq form (acode-unwrapped-form form))
439             (when (acode-p form)
440               (let* ((op (acode-operator form)))
441                 (cond ((eql op (%nx1-operator eq))
442                        (destructuring-bind (cc x y) (acode-operands form)
443                          (when (eq :eq (acode-immediate-operand cc))
444                            (if (setq var (nx2-lexical-reference-p x))
445                              (setq fixval (acode-fixnum-form-p y))
446                              (if (setq var (nx2-lexical-reference-p y))
447                                (setq fixval (acode-fixnum-form-p x)))))))
448                       ((eql op (%nx1-operator %izerop))
449                        (destructuring-bind (cc val) (acode-operands form)
450                          (when (eq :eq (acode-immediate-operand cc))
451                            (setq var (nx2-lexical-reference-p val)
452                                  fixval 0)))))))
453             (if (and var fixval)
454               (values var fixval)
455               (values nil nil)))))
456    (setq form (acode-unwrapped-form form))
457    (multiple-value-bind (var val) (is-simple-comparison-of-var-to-fixnum form)
458      (if var
459        (values var (list val))
460        (if (and (acode-p form) (eql (acode-operator form) (%nx1-operator or)))
461          (collect ((vals))
462            (let* ((clauselist (car (acode-operands  form))))
463              (if (multiple-value-setq (var val) (is-simple-comparison-of-var-to-fixnum (car clauselist)))
464                (progn
465                  (vals val)
466                  (dolist (clause (cdr clauselist) (values var (vals)))
467                    (multiple-value-bind (var1 val1)
468                        (is-simple-comparison-of-var-to-fixnum clause)
469                      (unless (eq var var1)
470                        (return (values nil nil)))
471                      (vals val1))))
472                (values nil nil)))))))))
473           
474
475
476                   
477               
478       
479               
480;;; If an IF form (in acode) appears to be the expansion of a
481;;; CASE/ECASE/CCASE where all values are fixnums, try to recover
482;;; that information and let the backend decide what to do with it.
483;;; (A backend might plausibly replace a sequence of comparisons with
484;;; a jumptable.)
485;;; Returns 4 values: a list of lists of fixnums, the corresponding true
486;;; forms for each sublist, the variable being tested, and the "otherwise"
487;;; or default form.
488;;; Something like (IF (EQL X 1) (FOO) (BAR)) will return non-nil values.
489;;; The backend -could- generate a jump table in that case, but probably
490;;; wouldn't want to.
491(defun nx2-reconstruct-case (test true false)
492  (multiple-value-bind (var vals) (nx2-is-comparison-of-var-to-fixnums test)
493    (if (not var)
494      (values nil nil nil nil)
495      (collect ((ranges)
496                (trueforms))
497        (let* ((otherwise nil))
498          (ranges vals)
499          (trueforms true)
500          (labels ((descend (original)
501                     (let* ((form (acode-unwrapped-form original)))
502                       (if (or (not (acode-p form))
503                               (not (eql (acode-operator form)
504                                         (%nx1-operator if))))
505                         (setq otherwise original)
506                         (destructuring-bind (test true false) (acode-operands form)
507                           (multiple-value-bind (v vals)
508                               (nx2-is-comparison-of-var-to-fixnums test)
509                             (cond ((eq v var)
510                                    (ranges vals)
511                                    (trueforms true)
512                                    (descend false))
513                                   (t (setq otherwise original)))))))))
514            (descend false))
515          (values (ranges) (trueforms) var otherwise))))))
516
517(defun acode-var-type (var trust-decls)
518  (do* ((var var bits)
519        (bits (var-bits var) (var-bits var)))
520       ((typep bits 'fixnum)
521        (or (var-type var)
522            (setf (var-type var)
523                  (let* ((initform (var-initform var)))
524                    (cond ((and initform (not (logbitp $vbitsetq bits)))
525                           (acode-form-type initform trust-decls))
526                          ((and trust-decls (var-declared-type var)))
527                          (t '*))))))))
528
529           
Note: See TracBrowser for help on using the repository browser.