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

Last change on this file since 15051 was 15051, checked in by gb, 8 years ago

nx2.lisp: New function NX2-VAR-NOT-REFFED-BY-FORM-P. Walks acode, returns
true iff it's sure that acode doesn't reference the specifed VAR.

x862.lisp: in the fixed-arg tail-call case of X862-SELF-CALL, don't
process arguments whose value isn't changing between the caller and
callee. If argument values are ultimately going to wind up in NVRs,
try to get them there directly. (This is only safe if no subequently-
processed argument values reference or set the variable's value. Setting
the NVR changes that value, and N-TARGETED-REG-FORMs isn't used to dealing
with that side-effect.)

File size: 41.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  (> (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-unboxed-type v)
154                (let* ((inittype (var-inittype v)))
155                  (when inittype
156                    (if (subtypep inittype 'double-float)
157                      (setf (var-declared-unboxed-type v) 'double-float)
158                      (if (subtypep inittype 'single-float)
159                        (setf (var-declared-unboxed-type v) 'single-float)))))))
160            (let* ((type (var-declared-unboxed-type v)))
161              (when (or (eq type 'single-float)
162                        (eq type 'double-float))
163                (push v fvars)))))))))
164         
165               
166             
167
168(defun nx2-constant-form-p (form)
169  (setq form (nx-untyped-form form))
170  (if form
171    (or (nx-null form)
172        (nx-t form)
173        (and (consp form)
174             (or (eq (acode-operator form) (%nx1-operator immediate))
175                 (eq (acode-operator form) (%nx1-operator fixnum))
176                 (eq (acode-operator form) (%nx1-operator simple-function)))))))
177
178(defun nx2-lexical-reference-p (form)
179  (when (acode-p form)
180    (let ((op (acode-operator (setq form (acode-unwrapped-form-value form)))))
181      (when (or (eq op (%nx1-operator lexical-reference))
182                (eq op (%nx1-operator inherited-arg)))
183        (%cadr form)))))
184
185(defun nx2-acode-call-p (form)
186  (when (acode-p form)
187    (let ((op (acode-operator (acode-unwrapped-form-value form))))
188      (or (eq op (%nx1-operator multiple-value-call))
189          (eq op (%nx1-operator call))
190          (eq op (%nx1-operator lexical-function-call))
191          (eq op (%nx1-operator self-call))
192          (eq op (%nx1-operator builtin-call))))))
193         
194 
195
196;;; Returns true iff lexical variable VAR isn't setq'ed in FORM.
197;;; Punts a lot ...
198(defun nx2-var-not-set-by-form-p (var form)
199  (let* ((bits (nx-var-bits var)))
200    (or (not (%ilogbitp $vbitsetq bits))
201        (nx2-setqed-var-not-set-by-form-p var form (logbitp $vbitclosed bits)))))
202
203(defun nx2-setqed-var-not-set-by-form-p (var form &optional closed)
204  (setq form (acode-unwrapped-form form))
205  (or (atom form)
206      (nx2-constant-form-p form)
207      (nx2-lexical-reference-p form)
208      (let ((op (acode-operator form))
209            (subforms nil))
210        (if (eq op (%nx1-operator setq-lexical))
211          (and (neq var (cadr form))
212               (nx2-setqed-var-not-set-by-form-p var (caddr form)))
213          (and (or (not closed)
214                   (logbitp operator-side-effect-free-bit op))
215               (flet ((not-set-in-formlist (formlist)
216                        (dolist (subform formlist t)
217                          (unless (nx2-setqed-var-not-set-by-form-p var subform closed) (return)))))
218                 (if
219                   (cond ((%ilogbitp operator-acode-subforms-bit op) (setq subforms (%cdr form)))
220                         ((%ilogbitp operator-acode-list-bit op) (setq subforms (cadr form))))
221                   (not-set-in-formlist subforms)
222                   (and (or (eq op (%nx1-operator call))
223                            (eq op (%nx1-operator lexical-function-call)))
224                        (nx2-setqed-var-not-set-by-form-p var (cadr form))
225                        (setq subforms (caddr form))
226                        (not-set-in-formlist (car subforms))
227                        (not-set-in-formlist (cadr subforms))))))))))
228
229(defun nx2-var-not-reffed-by-form-p (var form &optional closed)
230  (setq form (acode-unwrapped-form form))
231  (unless (eq var (nx2-lexical-reference-p form))
232    (or (atom form)
233        (nx2-lexical-reference-p form)  ;not us
234        (nx2-constant-form-p form)
235        (let ((op (acode-operator form))
236              (subforms nil))
237          (if (eq op (%nx1-operator setq-lexical))
238            (and (neq var (cadr form))
239                 (nx2-var-not-reffed-by-form-p var (caddr form)))
240            (and (or (not closed)
241                     (logbitp operator-side-effect-free-bit op))
242                 (flet ((not-reffed-in-formlist (formlist)
243                          (dolist (subform formlist t)
244                            (unless (nx2-var-not-reffed-by-form-p var subform closed) (return)))))
245                   (if
246                     (cond ((%ilogbitp operator-acode-subforms-bit op) (setq subforms (%cdr form)))
247                           ((%ilogbitp operator-acode-list-bit op) (setq subforms (cadr form))))
248                     (not-reffed-in-formlist subforms)
249                     (and (or (eq op (%nx1-operator call))
250                              (eq op (%nx1-operator lexical-function-call)))
251                          (nx2-var-not-reffed-by-form-p var (cadr form))
252                          (setq subforms (caddr form))
253                          (not-reffed-in-formlist (car subforms))
254                          (not-reffed-in-formlist (cadr subforms)))))))))))
255
256(defun nx2-node-gpr-p (reg)
257  (and reg
258       (eql (hard-regspec-class reg) hard-reg-class-gpr)
259       (eql (get-regspec-mode reg) hard-reg-class-gpr-mode-node)))
260
261;;; ENTRIES is a list of recorded-symbol entries, built by pushing
262;;; info for each variable referenced by the function AFUNC as it
263;;; comes into scope.  (Inherited variables "come into scope" before
264;;; anything else, then required arguments, etc.)  Supplied-p variables
265;;; may come into scope before "real" arglist entries do, which confuses
266;;; functions that try to construct a function's arglist from the symbol
267;;; map.  I -think- that confusion only exists when supplied-p variables
268;;; are involved, so this returns its first argument unless they are;
269;;; otherwise, it ensures that all toplevel arglist symbols are followed
270;;; only by any inherited variables, and that the arglist symbols are
271;;; in the correct (reversed) order
272(defun nx2-recorded-symbols-in-arglist-order (entries afunc)
273  (let* ((alambda (afunc-acode afunc)))
274    (when (and (acode-p alambda)
275               (eq (acode-operator alambda) (%nx1-operator lambda-list)))
276      (destructuring-bind (req opt rest keys &rest ignore) (cdr alambda)
277        (declare (ignore ignore))
278        (when (or (dolist (sp (caddr opt))
279                    (when sp (return t)))
280                  (dolist (sp (caddr keys))
281                    (when sp (return t))))
282          (let* ((new ()))
283            (flet ((info-for-var (var)
284                     (assoc var entries :test #'eq)))
285              (flet ((add-new-info (var)
286                       (let* ((info (info-for-var var)))
287                         (when info
288                           (push info new)))))
289                (setq entries (nreverse entries))
290                (dolist (var (afunc-inherited-vars afunc))
291                  (add-new-info var))
292                (dolist (r req)
293                  (add-new-info r))
294                (dolist (o (car opt))
295                  (add-new-info o))
296                (when (consp rest)
297                  (setq rest (car rest)))
298                (when rest
299                  (add-new-info rest))
300                (dolist (k (cadr keys))
301                  (add-new-info k))
302                (dolist (e entries)
303                  (unless (member e new :test #'eq)
304                    (push e new)))
305                (setq entries new)))))))
306    entries))
307
308(defun nx2-replace-var-refs (var value)
309  (when (acode-p value)
310    (let* ((op (acode-operator value))
311           (operands (acode-operands value)))
312      (when (typep op 'fixnum)
313        (dolist (ref (var-ref-forms var) (setf (var-ref-forms var) nil))
314          (when (acode-p ref)
315            (setf (acode-operator ref) op
316                  (acode-operands ref) operands)))))))
317
318(defun acode-immediate-operand (x)
319  (let* ((x (acode-unwrapped-form x)))
320    (if (eq (acode-operator x) (%nx1-operator immediate))
321      (cadr x)
322      (compiler-bug "not an immediate: ~s" x))))
323
324(defun nx2-constant-index-ok-for-type-keyword (idx keyword)
325  (when (>= idx 0)
326    (let* ((arch (backend-target-arch *target-backend*))
327           (limit
328            (case keyword
329              ((:bignum 
330                :single-float 
331                :double-float 
332                :xcode-vector
333                :signed-32-bit-vector 
334                :unsigned-32-bit-vector 
335                :single-float-vector 
336                :simple-string)
337               (arch::target-max-32-bit-constant-index arch))
338              (:bit-vector (arch::target-max-1-bit-constant-index arch))
339              ((:signed-8-bit-vector :unsigned-8-bit-vector)
340               (arch::target-max-8-bit-constant-index arch))
341              ((:signed-16-bit-vector :unsigned-16-bit-vector)
342               (arch::target-max-16-bit-constant-index arch))
343              ((:signed-64-bit-vector 
344                :unsigned-64-bit-vector 
345                :double-float-vector)
346               (arch::target-max-64-bit-constant-index arch))
347              (t
348               ;; :fixnum or node
349               (target-word-size-case
350                (32 (arch::target-max-32-bit-constant-index arch))
351                (64 (arch::target-max-64-bit-constant-index arch)))))))
352      (and limit (< idx limit)))))
353
354(defun backend-use-operator (op seg vreg xfer &rest forms)
355  (declare (dynamic-extent forms))
356  (apply (svref (backend-p2-dispatch *target-backend*)
357                (%ilogand op operator-id-mask))
358         seg vreg xfer forms))
359
360(defun backend-apply-acode (acode seg vreg xfer)
361  (apply (svref (backend-p2-dispatch *target-backend*)
362                (%ilogand (acode-operator acode) operator-id-mask))
363         seg vreg xfer (acode-operands acode)))
364
365
366(defun acode-constant-p (form)
367  ;; This returns (values constant-value constantp); some code
368  ;; may need to check constantp if constant-value is nil.
369  (let* ((form (acode-unwrapped-form-value form))
370         (op (if (acode-p form) (acode-operator form))))
371    (cond ((eql op (%nx1-operator nil))
372           (values nil t))
373          ((eql op (%nx1-operator t))
374           (values t t))
375          ((or (eql op (%nx1-operator fixnum))
376               (eql op (%nx1-operator immediate)))
377           (values (cadr form) t))
378          (t (values nil nil)))))
379
380(defun acode-constant-fold-binop (seg vreg xfer x y function)
381  (multiple-value-bind (const-x x-p) (acode-constant-p x)
382    (when x-p
383      (multiple-value-bind (const-y y-p) (acode-constant-p y)
384        (when y-p
385          (let* ((result (ignore-errors (funcall function const-x const-y))))
386            (when result
387              (backend-use-operator (if (nx1-target-fixnump result)
388                                      (%nx1-operator fixnum)
389                                      (%nx1-operator immediate))
390                                    seg
391                                    vreg
392                                    xfer
393                                    result)
394              t)))))))
395
396;;; Return non-nil iff we can do something better than a subprim call
397;;; to .SPbuiltin-ash.
398(defun acode-optimize-ash (seg vreg xfer num amt trust-decls &optional (result-type 'integer))
399  (let* ((unsigned-natural-type *nx-target-natural-type*)
400         (target-fixnum-type *nx-target-fixnum-type*)
401         (max (target-word-size-case (32 32) (64 64)))
402         (maxbits (target-word-size-case
403                   (32 29)
404                   (64 60)))
405         (const-num (acode-integer-form-p num))
406         (const-amt (acode-integer-form-p amt))
407         (shifted (and const-num const-amt (ash const-num const-amt))))
408    (cond (shifted
409           (if (nx1-target-fixnump shifted)
410             (backend-use-operator (%nx1-operator fixnum) seg vreg xfer shifted)
411             (backend-use-operator (%nx1-operator immediate) seg vreg xfer shifted))
412           t)
413          ((eql const-amt 0)
414           (backend-use-operator (%nx1-operator require-integer) seg vreg xfer num)
415           t)
416          ((and (fixnump const-amt) (< const-amt 0))
417           (if (acode-form-typep num target-fixnum-type trust-decls)
418             (progn
419               (backend-use-operator (%nx1-operator %iasr)
420                                     seg
421                                     vreg
422                                     xfer
423                                     (make-acode (%nx1-operator fixnum)
424                                                 (- const-amt))
425                                     num)
426               t)
427             (if (acode-form-typep num unsigned-natural-type trust-decls)
428               (progn
429                 (if (< (- const-amt) max)
430                   (backend-use-operator (%nx1-operator natural-shift-right)
431                                         seg
432                                         vreg
433                                         xfer
434                                         num
435                                         (make-acode (%nx1-operator fixnum)
436                                                   (- const-amt)))
437                   (progn
438                     (backend-use-operator (target-word-size-case
439                                            (32 (%nx1-operator require-u32))
440                                            (64 (%nx1-operator require-u64)))
441                                           seg
442                                           nil
443                                           nil
444                                           num)
445                     (backend-use-operator (%nx1-operator fixnum)
446                                           seg
447                                           vreg
448                                           xfer
449                                           0)))
450                 t))))
451          ((and (fixnump const-amt)
452                (<= 0 const-amt maxbits)
453                (or (acode-form-typep num `(signed-byte ,(- (1+ maxbits) const-amt)) trust-decls)
454                      (and (acode-form-typep num 'fixnum trust-decls)
455                           trust-decls
456                           (subtypep result-type 'fixnum))))
457           (progn
458             (backend-use-operator (%nx1-operator %ilsl)
459                                   seg
460                                   vreg
461                                   xfer
462                                   (make-acode (%nx1-operator fixnum)
463                                               const-amt)
464                                   num)
465             t))
466          ((and (fixnump const-amt)
467                (< 0 const-amt max)
468                (acode-form-typep num unsigned-natural-type trust-decls)
469                trust-decls
470                (subtypep result-type unsigned-natural-type))
471           (backend-use-operator (%nx1-operator natural-shift-left)
472                                 seg
473                                 vreg
474                                 xfer
475                                 num
476                                 amt)
477           t)
478          ((typep const-num target-fixnum-type)
479           (let* ((field-width (1+ (integer-length const-num)))
480                    ;; num fits in a `(signed-byte ,field-width)
481                    (max-shift (- (1+ maxbits) field-width)))
482               (when (acode-form-typep amt `(mod ,(1+ max-shift)) trust-decls)
483                 (backend-use-operator (%nx1-operator %ilsl)
484                                       seg
485                                       vreg
486                                       xfer
487                                       amt
488                                       (make-acode (%nx1-operator fixnum)
489                                                   const-num))
490                 t)))
491          (t nil))))
492
493
494
495
496(defun acode-optimize-logand2 (seg vreg xfer num1 num2 trust-decls &optional (result-type 'integer))
497  (declare (ignore result-type))        ;see below
498  (or (acode-constant-fold-binop seg vreg xfer num1 num2 'logand)
499      (let* ((unsigned-natural-type *nx-target-natural-type*)
500             (target-fixnum-type *nx-target-fixnum-type*))
501        (cond ((eql (acode-fixnum-form-p num1) -1)
502               (backend-use-operator (%nx1-operator require-integer)
503                                     seg
504                                     vreg
505                                     xfer
506                                     num2)
507               t)
508              ((eql (acode-fixnum-form-p num2) -1)
509               (backend-use-operator (%nx1-operator require-integer)
510                                     seg
511                                     vreg
512                                     xfer
513                                     num1)
514               t)
515              ((and (acode-form-typep num1 target-fixnum-type trust-decls)
516                    (acode-form-typep num2 target-fixnum-type trust-decls))
517               (backend-use-operator (%nx1-operator %ilogand2)
518                                     seg
519                                     vreg
520                                     xfer
521                                     num1
522                                     num2)
523               t)
524              ((and (acode-form-typep num1 unsigned-natural-type trust-decls)
525                    (acode-form-typep num2 unsigned-natural-type trust-decls))
526               (backend-use-operator (%nx1-operator %natural-logand)
527                                     seg
528                                     vreg
529                                     xfer
530                                     num1
531                                     num2)
532               t)
533              ;; LOGAND of a natural integer N and a signed integer
534              ;; is a natural integer <= N, and there may be cases
535              ;; where we want to truncate a larger result to the
536              ;; machine word size based on the result type.  Later.
537              (t nil)))))
538
539(defun acode-optimize-logior2 (seg vreg xfer num1 num2 trust-decls &optional (result-type 'integer))
540  (declare (ignorable result-type))
541  (or (acode-constant-fold-binop seg vreg xfer num1 num2 'logior)
542      (let* ((unsigned-natural-type *nx-target-natural-type*)
543             (target-fixnum-type *nx-target-fixnum-type*))
544        (cond ((eql (acode-fixnum-form-p num1) 0)
545               (backend-use-operator (%nx1-operator require-integer)
546                                     seg
547                                     vreg
548                                     xfer
549                                     num2)
550               t)
551              ((eql (acode-fixnum-form-p num2) 0)
552               (backend-use-operator (%nx1-operator require-integer)
553                                     seg
554                                     vreg
555                                     xfer
556                                     num1)
557               t)
558              ((and (acode-form-typep num1 target-fixnum-type trust-decls)
559                    (acode-form-typep num2 target-fixnum-type trust-decls))
560               (backend-use-operator (%nx1-operator %ilogior2)
561                                     seg
562                                     vreg
563                                     xfer
564                                     num1
565                                     num2)
566               t)
567              ((and (acode-form-typep num1 unsigned-natural-type trust-decls)
568                    (acode-form-typep num2 unsigned-natural-type trust-decls))
569               (backend-use-operator (%nx1-operator %natural-logior)
570                                     seg
571                                     vreg
572                                     xfer
573                                     num1
574                                     num2)
575               t)
576              (t nil)))))
577
578(defun acode-optimize-logxor2 (seg vreg xfer num1 num2 trust-decls &optional (result-type 'integer))
579  (declare (ignorable result-type))
580  (or (acode-constant-fold-binop seg vreg xfer num1 num2 'logxor)
581      (let* ((unsigned-natural-type *nx-target-natural-type*)
582             (target-fixnum-type *nx-target-fixnum-type*))
583        (cond ((eql (acode-fixnum-form-p num1) 0)
584               (backend-use-operator (%nx1-operator require-integer)
585                                     seg
586                                     vreg
587                                     xfer
588                                     num2)
589               t)
590              ((eql (acode-fixnum-form-p num2) 0)
591               (backend-use-operator (%nx1-operator require-integer)
592                                     seg
593                                     vreg
594                                     xfer
595                                     num1)
596               t)
597              ((and (acode-form-typep num1 target-fixnum-type trust-decls)
598                    (acode-form-typep num2 target-fixnum-type trust-decls))
599               (backend-use-operator (%nx1-operator %ilogxor2)
600                                     seg
601                                     vreg
602                                     xfer
603                                     num1
604                                     num2)
605               t)
606              ((and (acode-form-typep num1 unsigned-natural-type trust-decls)
607                    (acode-form-typep num2 unsigned-natural-type trust-decls))
608               (backend-use-operator (%nx1-operator %natural-logxor)
609                                     seg
610                                     vreg
611                                     xfer
612                                     num1
613                                     num2)
614               t)
615              (t nil)))))
616
617
618
619(defun acode-optimize-add2 (seg vreg xfer num1 num2 trust-decls &optional (result-type 'number))
620  (declare (ignorable result-type))
621  (or (acode-constant-fold-binop seg vreg xfer num1 num2 '+)
622      (multiple-value-bind (num1 num2)
623          (nx-binop-numeric-contagion num1 num2 trust-decls)
624        (if (and (acode-form-typep num1 'double-float trust-decls)
625                 (acode-form-typep num2 'double-float trust-decls))
626          (progn
627            (backend-use-operator (%nx1-operator %double-float+-2)
628                                  seg
629                                  vreg
630                                  xfer
631                                  num1
632                                  num2)
633            t)
634          (if (and (acode-form-typep num1 'single-float trust-decls)
635                   (acode-form-typep num2 'single-float trust-decls))
636            (progn
637              (backend-use-operator (%nx1-operator %short-float+-2)
638                                    seg
639                                    vreg
640                                    xfer
641                                    num1
642                                    num2)
643              t)
644            (if (and (acode-form-typep num1 *nx-target-fixnum-type* trust-decls)
645                     (acode-form-typep num2 *nx-target-fixnum-type* trust-decls))
646              (progn
647                (backend-use-operator (%nx1-operator %i+)
648                                      seg
649                                      vreg
650                                      xfer
651                                      num1
652                                      num2
653                                      t)
654                t)))))))
655
656(defun acode-optimize-sub2 (seg vreg xfer num1 num2 trust-decls &optional (result-type 'number))
657  (declare (ignorable result-type))
658  (or (acode-constant-fold-binop seg vreg xfer num1 num2 '-)
659      (multiple-value-bind (num1 num2)
660          (nx-binop-numeric-contagion num1 num2 trust-decls)
661        (if (and (acode-form-typep num1 'double-float trust-decls)
662                 (acode-form-typep num2 'double-float trust-decls))
663          (progn
664            (backend-use-operator (%nx1-operator %double-float--2)
665                                  seg
666                                  vreg
667                                  xfer
668                                  num1
669                                  num2)
670            t)
671          (if (and (acode-form-typep num1 'single-float trust-decls)
672                   (acode-form-typep num2 'single-float trust-decls))
673            (progn
674              (backend-use-operator (%nx1-operator %short-float--2)
675                                    seg
676                                    vreg
677                                    xfer
678                                    num1
679                                    num2)
680              t)
681            (if (and (acode-form-typep num1 *nx-target-fixnum-type* trust-decls)
682                     (acode-form-typep num2 *nx-target-fixnum-type* trust-decls))
683              (progn
684                (if (eql (acode-constant-p num1) 0)
685                  (backend-use-operator (%nx1-operator %ineg) seg vreg xfer num2)
686                  (backend-use-operator (%nx1-operator %i-)
687                                        seg
688                                        vreg
689                                        xfer
690                                        num1
691                                        num2
692                                        t))
693                t)))))))
694       
695
696       
697(defun acode-optimize-mul2 (seg vreg xfer num1 num2 trust-decls &optional (result-type 'number))
698  (declare (ignorable result-type))
699  (or (acode-constant-fold-binop seg vreg xfer num1 num2 '*)
700      (let* ((f1 (acode-fixnum-form-p num1)))
701        (when f1
702          (cond ((and (eql f1 1)
703                      (acode-form-typep num2 'number trust-decls))
704                 (backend-apply-acode num2 seg vreg xfer)
705                 t)
706                ((and (eql (logcount f1) 1)
707                      (> f1 0)
708                      (acode-form-typep num2 *nx-target-fixnum-type* trust-decls))
709                 (backend-use-operator (%nx1-operator ash)
710                                       seg
711                                       vreg
712                                       xfer
713                                       num2
714                                       (make-acode (%nx1-operator fixnum)
715                                                   (1- (integer-length f1))))
716                 t))))
717      (let* ((f2 (acode-fixnum-form-p num2)))
718        (when f2
719          (cond ((and (eql f2 1)
720                      (acode-form-typep num1 'number trust-decls))
721                 (backend-apply-acode num1 seg vreg xfer)
722                 t)
723                ((and (eql (logcount f2) 1)
724                      (> f2 0)
725                      (acode-form-typep num1 *nx-target-fixnum-type* trust-decls))
726                 (backend-use-operator (%nx1-operator ash)
727                                       seg
728                                       vreg
729                                       xfer
730                                       num1
731                                       (make-acode (%nx1-operator fixnum)
732                                                   (1- (integer-length f2))))
733                 t))))
734      (multiple-value-bind (form1 form2)
735          (nx-binop-numeric-contagion num1 num2 trust-decls)
736        (if (and (acode-form-typep form1 'double-float trust-decls)
737                 (acode-form-typep form2 'double-float trust-decls))
738          (progn
739            (backend-use-operator (%nx1-operator %double-float*-2)
740                                  seg
741                                  vreg
742                                  xfer
743                                  form1
744                                  form2)
745            t)
746          (if (and (acode-form-typep form1 'single-float trust-decls)
747                   (acode-form-typep form2 'single-float trust-decls))
748            (progn
749              (backend-use-operator (%nx1-operator %short-float*-2)
750                                    seg
751                                    vreg
752                                    xfer
753                                    form1
754                                    form2)
755              t))))))
756
757(defun acode-optimize-div2 (seg vreg xfer num1 num2 trust-decls &optional (result-type 'number))
758  (declare (ignorable result-type))
759  (or (acode-constant-fold-binop seg vreg xfer num1 num2 '/)
760      (multiple-value-bind (num1 num2)
761          (nx-binop-numeric-contagion num1 num2 trust-decls)
762        (if (and (acode-form-typep num1 'double-float trust-decls)
763                 (acode-form-typep num2 'double-float trust-decls))
764          (progn
765            (backend-use-operator (%nx1-operator %double-float/-2)
766                                  seg
767                                  vreg
768                                  xfer
769                                  num1
770                                  num2)
771            t)
772          (if (and (acode-form-typep num1 'single-float trust-decls)
773                   (acode-form-typep num2 'single-float trust-decls))
774            (progn
775              (backend-use-operator (%nx1-operator %short-float/-2)
776                                    seg
777                                    vreg
778                                    xfer
779                                    num1
780                                    num2)
781              t)
782            (let* ((f2 (acode-fixnum-form-p num2))
783                   (unwrapped (acode-unwrapped-form num1))
784                   (f1 nil)
785                   (f1/f2 nil))
786              (if (and f2
787                       (not (zerop f2))
788                       (acode-p unwrapped)
789                       (or (eq (acode-operator unwrapped) (%nx1-operator mul2))
790                           (eq (acode-operator unwrapped) (%nx1-operator %i*)))
791                       (setq f1 (acode-fixnum-form-p (cadr unwrapped)))
792                       (typep (setq f1/f2 (/ f1 f2)) 'fixnum))
793                (progn
794                  (backend-use-operator (%nx1-operator mul2)
795                                        seg
796                                        vreg
797                                        xfer
798                                        (make-acode (%nx1-operator fixnum) f1/f2)
799                                        (caddr unwrapped))
800                  t))))))))
801
802(defun acode-optimize-numcmp (seg vreg xfer cc num1 num2 trust-decls &optional (result-type 'boolean))
803  (declare (ignorable result-type))
804  (cond ((and (acode-form-typep num1 *nx-target-fixnum-type* trust-decls)
805              (acode-form-typep num2 *nx-target-fixnum-type* trust-decls))
806         (backend-use-operator (%nx1-operator %i<>) seg vreg xfer cc num1 num2)
807         t)
808        ((and (acode-form-typep num1 *nx-target-natural-type* trust-decls)
809              (acode-form-typep num2 *nx-target-natural-type* trust-decls))
810         (backend-use-operator (%nx1-operator %natural<>) seg vreg xfer cc num1 num2)
811         t)
812        ((and (acode-form-typep num1 'double-float trust-decls)
813              (acode-form-typep num2 'double-float trust-decls))
814         (backend-use-operator (%nx1-operator double-float-compare) seg vreg xfer cc num1 num2)
815         t)
816        ((and (acode-form-typep num1 'single-float trust-decls)
817              (acode-form-typep num2 'single-float trust-decls))
818         (backend-use-operator (%nx1-operator short-float-compare) seg vreg xfer cc num1 num2)
819         t)))
820
821(defun acode-optimize-minus1 (seg vreg xfer form trust-decls &optional (result-type 'number))
822  (declare (ignorable result-type))
823  (multiple-value-bind (val constp) (acode-constant-p form)
824    (cond ((and (and constp (ignore-errors (setq val (- val)))))
825           (backend-use-operator (if (typep val *nx-target-fixnum-type*)
826                                   (%nx1-operator fixnum)
827                                   (%nx1-operator immediate))
828                                 seg vreg xfer val)
829           t)
830          ((acode-form-typep form 'double-float trust-decls)
831           (backend-use-operator (%nx1-operator %double-float-negate) seg vreg xfer form)
832           t)
833          ((acode-form-typep form 'single-float trust-decls)
834           (backend-use-operator (%nx1-operator %single-float-negate) seg vreg xfer form)
835           t)
836          ((acode-form-typep form *nx-target-fixnum-type* trust-decls)
837           (backend-use-operator (%nx1-operator %ineg) seg vreg xfer form)
838           t))))
839
840(defun nx2-is-comparison-of-var-to-fixnums (form)
841  ;; Catches some cases.  May miss some.
842  (flet ((is-simple-comparison-of-var-to-fixnum (form)
843           (let* ((var nil)
844                  (fixval nil))
845             (setq form (acode-unwrapped-form form))
846             (when (acode-p form)
847               (let* ((op (acode-operator form)))
848                 (cond ((eql op (%nx1-operator eq))
849                        (destructuring-bind (cc x y) (cdr form)
850                          (when (eq :eq (acode-immediate-operand cc))
851                            (if (setq var (nx2-lexical-reference-p x))
852                              (setq fixval (acode-fixnum-form-p y))
853                              (if (setq var (nx2-lexical-reference-p y))
854                                (setq fixval (acode-fixnum-form-p x)))))))
855                       ((eql op (%nx1-operator %izerop))
856                        (destructuring-bind (cc val) (cdr form)
857                          (when (eq :eq (acode-immediate-operand cc))
858                            (setq var (nx2-lexical-reference-p val)
859                                  fixval 0)))))))
860             (if (and var fixval)
861               (values var fixval)
862               (values nil nil)))))
863    (setq form (acode-unwrapped-form form))
864    (multiple-value-bind (var val) (is-simple-comparison-of-var-to-fixnum form)
865      (if var
866        (values var (list val))
867        (if (and (acode-p form) (eql (acode-operator form) (%nx1-operator or)))
868          (collect ((vals))
869            (let* ((clauselist (cadr form)))
870              (if (multiple-value-setq (var val) (is-simple-comparison-of-var-to-fixnum (car clauselist)))
871                (progn
872                  (vals val)
873                  (dolist (clause (cdr clauselist) (values var (vals)))
874                    (multiple-value-bind (var1 val1)
875                        (is-simple-comparison-of-var-to-fixnum clause)
876                      (unless (eq var var1)
877                        (return (values nil nil)))
878                      (vals val1))))
879                (values nil nil)))))))))
880           
881
882
883                   
884               
885       
886               
887;;; If an IF form (in acode) appears to be the expansion of a
888;;; CASE/ECASE/CCASE where all values are fixnums, try to recover
889;;; that information and let the backend decide what to do with it.
890;;; (A backend might plausibly replace a sequence of comparisons with
891;;; a jumptable.)
892;;; Returns 4 values: a list of lists of fixnums, the corresponding true
893;;; forms for each sublist, the variable being tested, and the "otherwise"
894;;; or default form.
895;;; Something like (IF (EQL X 1) (FOO) (BAR)) will return non-nil values.
896;;; The backend -could- generate a jump table in that case, but probably
897;;; wouldn't want to.
898(defun nx2-reconstruct-case (test true false)
899  (multiple-value-bind (var vals) (nx2-is-comparison-of-var-to-fixnums test)
900    (if (not var)
901      (values nil nil nil nil)
902      (collect ((ranges)
903                (trueforms))
904        (let* ((otherwise nil))
905          (ranges vals)
906          (trueforms true)
907          (labels ((descend (original)
908                     (let* ((form (acode-unwrapped-form original)))
909                       (if (or (not (acode-p form))
910                               (not (eql (acode-operator form)
911                                         (%nx1-operator if))))
912                         (setq otherwise original)
913                         (destructuring-bind (test true false) (cdr form)
914                           (multiple-value-bind (v vals)
915                               (nx2-is-comparison-of-var-to-fixnums test)
916                             (cond ((eq v var)
917                                    (ranges vals)
918                                    (trueforms true)
919                                    (descend false))
920                                   (t (setq otherwise original)))))))))
921            (descend false))
922          (values (ranges) (trueforms) var otherwise))))))
Note: See TracBrowser for help on using the repository browser.