Fix make-array transforms.
[sbcl.git] / src / compiler / x86 / pred.lisp
1 ;;;; predicate VOPs for the x86 VM
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!VM")
13 \f
14 ;;;; the branch VOP
15
16 ;;; The unconditional branch, emitted when we can't drop through to the desired
17 ;;; destination. Dest is the continuation we transfer control to.
18 (define-vop (branch)
19   (:info dest)
20   (:generator 5
21     (inst jmp dest)))
22
23 \f
24 ;;;; Generic conditional VOPs
25
26 ;;; The generic conditional branch, emitted immediately after test
27 ;;; VOPs that only set flags.
28 ;;;
29 ;;; FLAGS is a list of condition descriptors. If the first descriptor
30 ;;; is CL:NOT, the test was true if all the remaining conditions are
31 ;;; false. Otherwise, the test was true if any of the conditions is.
32 ;;;
33 ;;; NOT-P flips the meaning of the test, as with regular :CONDITIONAL
34 ;;; VOP. If NOT-P is true, the code must branch to dest if the test was
35 ;;; false. Otherwise, the code must branch to dest if the test was true.
36
37 (define-vop (branch-if)
38   (:info dest flags not-p)
39   (:generator 0
40      (flet ((negate-condition (name)
41               (let ((code (logxor 1 (conditional-opcode name))))
42                 (aref *condition-name-vec* code))))
43        (aver (null (rest flags)))
44        (inst jmp
45              (if not-p
46                  (negate-condition (first flags))
47                  (first flags))
48              dest))))
49
50 (defvar *cmov-ptype-representation-vop*
51   (mapcan (lambda (entry)
52             (destructuring-bind (ptypes &optional sc vop)
53                 entry
54               (unless (listp ptypes)
55                 (setf ptypes (list ptypes)))
56               (mapcar (if (and vop sc)
57                           (lambda (ptype)
58                             (list ptype sc vop))
59                           #'list)
60                       ptypes)))
61           '((t descriptor-reg move-if/t)
62
63             ((fixnum positive-fixnum)
64              any-reg move-if/fx)
65             ((unsigned-byte-32 unsigned-byte-31)
66              unsigned-reg move-if/unsigned)
67             (signed-byte-32 signed-reg move-if/signed)
68             ;; FIXME: Can't use CMOV with byte registers, and characters live
69             ;; in such outside of unicode builds. A better solution then just
70             ;; disabling MOVE-IF/CHAR should be possible, though.
71             #!+sb-unicode
72             (character character-reg move-if/char)
73
74             ((single-float complex-single-float
75               double-float complex-double-float))
76
77             (system-area-pointer sap-reg move-if/sap)))
78   "Alist of primitive type -> (storage-class-name VOP-name)
79    if values of such a type should be cmoved, and NIL otherwise.
80
81    storage-class-name is the name of the storage class to use for
82    the values, and VOP-name the name of the VOP that will be used
83    to execute the conditional move.")
84
85 (defun convert-conditional-move-p (node dst-tn x-tn y-tn)
86   (declare (ignore node))
87   (let* ((ptype (sb!c::tn-primitive-type dst-tn))
88          (name  (sb!c::primitive-type-name ptype))
89          (param (and (memq :cmov *backend-subfeatures*)
90                      (cdr (or (assoc name *cmov-ptype-representation-vop*)
91                               '(t descriptor-reg move-if/t))))))
92     (when param
93       (destructuring-bind (representation vop) param
94         (let ((scn (sc-number-or-lose representation)))
95           (labels ((make-tn ()
96                      (make-representation-tn ptype scn))
97                    (frob-tn (tn)
98                      (if (immediate-tn-p tn)
99                          tn
100                          (make-tn))))
101             (values vop
102                     (frob-tn x-tn) (frob-tn y-tn)
103                     (make-tn)
104                     nil)))))))
105
106 (define-vop (move-if)
107   (:args (then) (else))
108   (:temporary (:sc unsigned-reg :from :eval) temp)
109   (:results (res))
110   (:info flags)
111   (:generator 0
112      (flet ((load-immediate (dst constant-tn
113                                  &optional (sc (sc-name (tn-sc dst))))
114               (let ((val (tn-value constant-tn)))
115                 (etypecase val
116                   (integer
117                      (if (memq sc '(any-reg descriptor-reg))
118                          (inst mov dst (fixnumize val))
119                          (inst mov dst val)))
120                   (symbol
121                      (aver (eq sc 'descriptor-reg))
122                      (load-symbol dst val))
123                   (character
124                      (cond ((memq sc '(any-reg descriptor-reg))
125                             (inst mov dst
126                                   (logior (ash (char-code val) n-widetag-bits)
127                                           character-widetag)))
128                            (t
129                             (aver (eq sc 'character-reg))
130                             (inst mov dst (char-code val)))))))))
131        (aver (null (rest flags)))
132        (if (sc-is else immediate)
133            (load-immediate res else)
134            (move res else))
135        (when (sc-is then immediate)
136          (load-immediate temp then (sc-name (tn-sc res)))
137          (setf then temp))
138        (inst cmov (first flags) res then))))
139
140 (macrolet ((def-move-if (name type reg stack)
141                `(define-vop (,name move-if)
142                   (:args (then :scs (immediate ,reg ,stack) :to :eval
143                                :target temp
144                                :load-if (not (or (sc-is then immediate)
145                                                  (and (sc-is then ,stack)
146                                                       (not (location= else res))))))
147                          (else :scs (immediate ,reg ,stack) :target res
148                                :load-if (not (sc-is else immediate ,stack))))
149                   (:arg-types ,type ,type)
150                   (:results (res :scs (,reg)
151                                  :from (:argument 1)))
152                   (:result-types ,type))))
153   (def-move-if move-if/t t descriptor-reg control-stack)
154   (def-move-if move-if/fx tagged-num any-reg control-stack)
155   (def-move-if move-if/unsigned unsigned-num unsigned-reg unsigned-stack)
156   (def-move-if move-if/signed signed-num signed-reg signed-stack)
157   ;; FIXME: See *CMOV-PTYPE-REPRESENTATION-VOP* above.
158   #!+sb-unicode
159   (def-move-if move-if/char character character-reg character-stack)
160   (def-move-if move-if/sap system-area-pointer sap-reg sap-stack))
161
162 \f
163 ;;;; conditional VOPs
164
165 ;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement,
166 ;;; not immediate data.
167 (define-vop (if-eq)
168   (:args (x :scs (any-reg descriptor-reg control-stack constant)
169             :load-if (not (and (sc-is x immediate)
170                                (sc-is y any-reg descriptor-reg
171                                       control-stack constant))))
172          (y :scs (any-reg descriptor-reg immediate)
173             :load-if (not (and (sc-is x any-reg descriptor-reg immediate)
174                                (sc-is y control-stack constant)))))
175   (:conditional :e)
176   (:info)
177   (:policy :fast-safe)
178   (:translate eq)
179   (:generator 6
180     (let ((x-val (encode-value-if-immediate x))
181           (y-val (encode-value-if-immediate y)))
182       (cond
183         ;; Shorter instruction sequences for these two cases.
184         ((and (eql 0 y-val) (sc-is x any-reg descriptor-reg)) (inst test x x))
185         ((and (eql 0 x-val) (sc-is y any-reg descriptor-reg)) (inst test y y))
186
187         ;; An encoded value (literal integer) has to be the second argument.
188         ((sc-is x immediate) (inst cmp y x-val))
189
190         (t (inst cmp x y-val))))))
191
192 (macrolet ((def (eq-name eql-name cost)
193              `(define-vop (,eq-name ,eql-name)
194                 (:translate eq)
195                 (:variant-cost ,cost))))
196   (def fast-if-eq-character fast-char=/character 3)
197   (def fast-if-eq-character/c fast-char=/character/c 2)
198   (def fast-if-eq-fixnum fast-eql/fixnum 3)
199   (def fast-if-eq-fixnum/c fast-eql-c/fixnum 2)
200   (def fast-if-eq-signed fast-if-eql/signed 5)
201   (def fast-if-eq-signed/c fast-if-eql-c/signed 4)
202   (def fast-if-eq-unsigned fast-if-eql/unsigned 5)
203   (def fast-if-eq-unsigned/c fast-if-eql-c/unsigned 4))