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

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

In NX2-AFUNC-ALLOCATE-GLOBAL-REGISTERS, increase var weight if
function (apparently) tailcalls itself.

Do self tail-calls involving small numbers of fixed args (currently,
one more than the number of args passed in registers, e.g., 4 on x8664
and 3 on x8632) better: avoid pushing/popping outgoing args, branch
back to a point after NVRs have been saved, etc.) There's still some
extra stack traffic and there's still room for improvement, but it's
better.

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