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

Last change on this file since 16111 was 16111, checked in by gb, 7 years ago

Recognize and maintain (some) bounded integer types; exploit this to
inline more fixnum arithmetic.

Lose the remaining ACODE-OPTIMIZE-FOO functions; replace them with
ACODE-REWRITE methods.

Don't strength-reduce in the frontend in some of the cases where we
still did

File size: 22.3 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  (> (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(defun acode-constant-p (form)
365  ;; This returns (values constant-value constantp); some code
366  ;; may need to check constantp if constant-value is nil.
367  (let* ((form (acode-unwrapped-form-value form))
368         (op (if (acode-p form) (acode-operator form))))
369    (cond ((eql op (%nx1-operator nil))
370           (values nil t))
371          ((eql op (%nx1-operator t))
372           (values t t))
373          ((or (eql op (%nx1-operator fixnum))
374               (eql op (%nx1-operator immediate)))
375           (values (car (acode-operands form)) t))
376          (t (values nil nil)))))
377
378(defun acode-constant-fold-binop (seg vreg xfer x y function)
379  (multiple-value-bind (const-x x-p) (acode-constant-p x)
380    (when x-p
381      (multiple-value-bind (const-y y-p) (acode-constant-p y)
382        (when y-p
383          (let* ((result (ignore-errors (funcall function const-x const-y))))
384            (when result
385              (backend-use-operator (if (nx1-target-fixnump result)
386                                      (%nx1-operator fixnum)
387                                      (%nx1-operator immediate))
388                                    seg
389                                    vreg
390                                    xfer
391                                    result)
392              t)))))))
393
394
395
396
397
398
399       
400
401
402
403(defun acode-optimize-minus1 (seg vreg xfer form trust-decls &optional (result-type 'number))
404  (declare (ignorable result-type))
405  (multiple-value-bind (val constp) (acode-constant-p form)
406    (cond ((and (and constp (ignore-errors (setq val (- val)))))
407           (backend-use-operator (if (typep val *nx-target-fixnum-type*)
408                                   (%nx1-operator fixnum)
409                                   (%nx1-operator immediate))
410                                 seg vreg xfer val)
411           t)
412          ((acode-form-typep form 'double-float trust-decls)
413           (backend-use-operator (%nx1-operator %double-float-negate) seg vreg xfer form)
414           t)
415          ((acode-form-typep form 'single-float trust-decls)
416           (backend-use-operator (%nx1-operator %single-float-negate) seg vreg xfer form)
417           t)
418          ((acode-form-typep form *nx-target-fixnum-type* trust-decls)
419           (backend-use-operator (%nx1-operator %ineg) seg vreg xfer form)
420           t))))
421
422(defun nx2-is-comparison-of-var-to-fixnums (form)
423  ;; Catches some cases.  May miss some.
424  (flet ((is-simple-comparison-of-var-to-fixnum (form)
425           (let* ((var nil)
426                  (fixval nil))
427             (setq form (acode-unwrapped-form form))
428             (when (acode-p form)
429               (let* ((op (acode-operator form)))
430                 (cond ((eql op (%nx1-operator eq))
431                        (destructuring-bind (cc x y) (acode-operands form)
432                          (when (eq :eq (acode-immediate-operand cc))
433                            (if (setq var (nx2-lexical-reference-p x))
434                              (setq fixval (acode-fixnum-form-p y))
435                              (if (setq var (nx2-lexical-reference-p y))
436                                (setq fixval (acode-fixnum-form-p x)))))))
437                       ((eql op (%nx1-operator %izerop))
438                        (destructuring-bind (cc val) (acode-operands form)
439                          (when (eq :eq (acode-immediate-operand cc))
440                            (setq var (nx2-lexical-reference-p val)
441                                  fixval 0)))))))
442             (if (and var fixval)
443               (values var fixval)
444               (values nil nil)))))
445    (setq form (acode-unwrapped-form form))
446    (multiple-value-bind (var val) (is-simple-comparison-of-var-to-fixnum form)
447      (if var
448        (values var (list val))
449        (if (and (acode-p form) (eql (acode-operator form) (%nx1-operator or)))
450          (collect ((vals))
451            (let* ((clauselist (car (acode-operands  form))))
452              (if (multiple-value-setq (var val) (is-simple-comparison-of-var-to-fixnum (car clauselist)))
453                (progn
454                  (vals val)
455                  (dolist (clause (cdr clauselist) (values var (vals)))
456                    (multiple-value-bind (var1 val1)
457                        (is-simple-comparison-of-var-to-fixnum clause)
458                      (unless (eq var var1)
459                        (return (values nil nil)))
460                      (vals val1))))
461                (values nil nil)))))))))
462           
463
464
465                   
466               
467       
468               
469;;; If an IF form (in acode) appears to be the expansion of a
470;;; CASE/ECASE/CCASE where all values are fixnums, try to recover
471;;; that information and let the backend decide what to do with it.
472;;; (A backend might plausibly replace a sequence of comparisons with
473;;; a jumptable.)
474;;; Returns 4 values: a list of lists of fixnums, the corresponding true
475;;; forms for each sublist, the variable being tested, and the "otherwise"
476;;; or default form.
477;;; Something like (IF (EQL X 1) (FOO) (BAR)) will return non-nil values.
478;;; The backend -could- generate a jump table in that case, but probably
479;;; wouldn't want to.
480(defun nx2-reconstruct-case (test true false)
481  (multiple-value-bind (var vals) (nx2-is-comparison-of-var-to-fixnums test)
482    (if (not var)
483      (values nil nil nil nil)
484      (collect ((ranges)
485                (trueforms))
486        (let* ((otherwise nil))
487          (ranges vals)
488          (trueforms true)
489          (labels ((descend (original)
490                     (let* ((form (acode-unwrapped-form original)))
491                       (if (or (not (acode-p form))
492                               (not (eql (acode-operator form)
493                                         (%nx1-operator if))))
494                         (setq otherwise original)
495                         (destructuring-bind (test true false) (acode-operands form)
496                           (multiple-value-bind (v vals)
497                               (nx2-is-comparison-of-var-to-fixnums test)
498                             (cond ((eq v var)
499                                    (ranges vals)
500                                    (trueforms true)
501                                    (descend false))
502                                   (t (setq otherwise original)))))))))
503            (descend false))
504          (values (ranges) (trueforms) var otherwise))))))
505
506(defun acode-var-type (var trust-decls)
507  (do* ((var var bits)
508        (bits (var-bits var) (var-bits var)))
509       ((typep bits 'fixnum)
510        (or (var-type var)
511            (setf (var-type var)
512                  (let* ((initform (var-initform var)))
513                    (cond ((and initform (not (logbitp $vbitsetq bits)))
514                           (acode-form-type initform trust-decls))
515                          ((and trust-decls (var-declared-type var)))
516                          (t '*))))))))
517
518           
Note: See TracBrowser for help on using the repository browser.