src/compiler/x86-64/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      (when (eq (car flags) 'not)
  41        (pop flags)
  42        (setf not-p (not not-p)))
  43      (flet ((negate-condition (name)
  44               (let ((code (logxor 1 (conditional-opcode name))))
  45                 (aref *condition-name-vec* code))))
  46        (cond ((null (rest flags))
  47               (inst jmp
  48                     (if not-p
  49                         (negate-condition (first flags))
  50                         (first flags))
  51                     dest))
  52              (not-p
  53               (let ((not-lab (gen-label))
  54                     (last    (car (last flags))))
  55                 (dolist (flag (butlast flags))
  56                   (inst jmp flag not-lab))
  57                 (inst jmp (negate-condition last) dest)
  58                 (emit-label not-lab)))
  59              (t
  60               (dolist (flag flags)
  61                 (inst jmp flag dest)))))))
  62
  63 (defvar *cmov-ptype-representation-vop*
  64   (mapcan (lambda (entry)
  65             (destructuring-bind (ptypes &optional sc vop)
  66                 entry
  67               (unless (listp ptypes)
  68                 (setf ptypes (list ptypes)))
  69               (mapcar (if (and vop sc)
  70                           (lambda (ptype)
  71                             (list ptype sc vop))
  72                           #'list)
  73                       ptypes)))
  74           '((t descriptor-reg move-if/t)
  75
  76             ((fixnum positive-fixnum)
  77              any-reg move-if/fx)
  78             ((unsigned-byte-64 unsigned-byte-63)
  79              unsigned-reg move-if/unsigned)
  80             (signed-byte-64 signed-reg move-if/signed)
  81             ;; FIXME: Can't use CMOV with byte registers, and characters live
  82             ;; in such outside of unicode builds. A better solution then just
  83             ;; disabling MOVE-IF/CHAR should be possible, though.
  84             #!+sb-unicode
  85             (character character-reg move-if/char)
  86
  87             ((single-float complex-single-float
  88               double-float complex-double-float))
  89
  90             (system-area-pointer sap-reg move-if/sap)))
  91   "Alist of primitive type -> (storage-class-name VOP-name)
  92    if values of such a type should be cmoved, and NIL otherwise.
  93
  94    storage-class-name is the name of the storage class to use for
  95    the values, and VOP-name the name of the VOP that will be used
  96    to execute the conditional move.")
  97
  98 (defun convert-conditional-move-p (node dst-tn x-tn y-tn)
  99   (declare (ignore node))
 100   (let* ((ptype (sb!c::tn-primitive-type dst-tn))
 101          (name  (sb!c::primitive-type-name ptype))
 102          (param (cdr (or (assoc name *cmov-ptype-representation-vop*)
 103                          '(t descriptor-reg move-if/t)))))
 104     (when param
 105       (destructuring-bind (representation vop) param
 106         (let ((scn (sc-number-or-lose representation)))
 107           (labels ((make-tn ()
 108                      (make-representation-tn ptype scn))
 109                    (frob-tn (tn)
 110                      (if (immediate-tn-p tn)
 111                          tn
 112                          (make-tn))))
 113             (values vop
 114                     (frob-tn x-tn) (frob-tn y-tn)
 115                     (make-tn)
 116                     nil)))))))
 117
 118 (define-vop (move-if)
 119   (:args (then) (else))
 120   (:results (res))
 121   (:info flags)
 122   (:generator 0
 123      (let ((not-p (eq (first flags) 'not)))
 124        (when not-p (pop flags))
 125        (flet ((negate-condition (name)
 126                 (let ((code (logxor 1 (conditional-opcode name))))
 127                   (aref *condition-name-vec* code)))
 128               (load-immediate (dst constant-tn
 129                                    &optional (sc (sc-name (tn-sc dst))))
 130                 (let ((val (tn-value constant-tn)))
 131                   (etypecase val
 132                     (integer
 133                        (if (memq sc '(any-reg descriptor-reg))
 134                            (inst mov dst (fixnumize val))
 135                            (inst mov dst val)))
 136                     (symbol
 137                        (aver (eq sc 'descriptor-reg))
 138                        (load-symbol dst val))
 139                     (character
 140                        (if (eq sc 'descriptor-reg)
 141                            (inst mov dst (logior (ash (char-code val) n-widetag-bits)
 142                                                  character-widetag))
 143                            (inst mov dst (char-code val))))))))
 144          (cond ((null (rest flags))
 145                 (if (sc-is else immediate)
 146                     (load-immediate res else)
 147                     (move res else))
 148                 (when (sc-is then immediate)
 149                   (load-immediate temp-reg-tn then (sc-name (tn-sc res)))
 150                   (setf then temp-reg-tn))
 151                 (inst cmov (if not-p
 152                                (negate-condition (first flags))
 153                                (first flags))
 154                       res
 155                       then))
 156                (not-p
 157                 (cond ((sc-is then immediate)
 158                        (when (location= else res)
 159                          (inst mov temp-reg-tn else)
 160                          (setf else temp-reg-tn))
 161                        (load-immediate res then))
 162                       ((location= else res)
 163                        (inst xchg else then)
 164                        (rotatef else then))
 165                       (t
 166                        (move res then)))
 167                 (when (sc-is else immediate)
 168                   (load-immediate temp-reg-tn else (sc-name (tn-sc res)))
 169                   (setf else temp-reg-tn))
 170                 (dolist (flag flags)
 171                   (inst cmov flag res else)))
 172                (t
 173                 (if (sc-is else immediate)
 174                     (load-immediate res else)
 175                     (move res else))
 176                 (when (sc-is then immediate)
 177                   (load-immediate temp-reg-tn then (sc-name (tn-sc res)))
 178                   (setf then temp-reg-tn))
 179                 (dolist (flag flags)
 180                   (inst cmov flag res then))))))))
 181
 182 (macrolet ((def-move-if (name type reg stack)
 183              `(define-vop (,name move-if)
 184                 (:args (then :scs (immediate ,reg ,stack) :to :eval
 185                              :load-if (not (or (sc-is then immediate)
 186                                                (and (sc-is then ,stack)
 187                                                     (not (location= else res))))))
 188                        (else :scs (immediate ,reg ,stack) :target res
 189                              :load-if (not (sc-is else immediate ,stack))))
 190                 (:arg-types ,type ,type)
 191                 (:results (res :scs (,reg)
 192                                :from (:argument 1)))
 193                 (:result-types ,type))))
 194   (def-move-if move-if/t t descriptor-reg control-stack)
 195   (def-move-if move-if/fx tagged-num any-reg control-stack)
 196   (def-move-if move-if/unsigned unsigned-num unsigned-reg unsigned-stack)
 197   (def-move-if move-if/signed signed-num signed-reg signed-stack)
 198   ;; FIXME: See *CMOV-PTYPE-REPRESENTATION-VOP* above.
 199   #!+sb-unicode
 200   (def-move-if move-if/char character character-reg character-stack)
 201   (def-move-if move-if/sap system-area-pointer sap-reg sap-stack))
 202 \f
 203 ;;;; conditional VOPs
 204
 205 ;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement,
 206 ;;; not immediate data.
 207 (define-vop (if-eq)
 208   (:args (x :scs (any-reg descriptor-reg control-stack constant)
 209             :load-if (not (and (sc-is x immediate)
 210                                (sc-is y any-reg descriptor-reg
 211                                       control-stack constant))))
 212          (y :scs (any-reg descriptor-reg immediate)
 213             :load-if (not (and (sc-is x any-reg descriptor-reg immediate)
 214                                (sc-is y control-stack constant)))))
 215   (:temporary (:sc descriptor-reg) temp)
 216   (:conditional :e)
 217   (:policy :fast-safe)
 218   (:translate eq)
 219   (:generator 6
 220     (cond
 221      ((sc-is y immediate)
 222       (let ((val (tn-value y)))
 223         (etypecase val
 224           (integer
 225            (if (and (zerop val) (sc-is x any-reg descriptor-reg))
 226                (inst test x x) ; smaller
 227              (let ((fixnumized (fixnumize val)))
 228                (if (typep fixnumized
 229                           '(or (signed-byte 32) (unsigned-byte 31)))
 230                    (inst cmp x fixnumized)
 231                  (progn
 232                    (inst mov temp fixnumized)
 233                    (inst cmp x temp))))))
 234           (symbol
 235            (inst cmp x (+ nil-value (static-symbol-offset val))))
 236           (character
 237            (inst cmp x (logior (ash (char-code val) n-widetag-bits)
 238                                character-widetag))))))
 239      ((sc-is x immediate) ; and y not immediate
 240       ;; Swap the order to fit the compare instruction.
 241       (let ((val (tn-value x)))
 242         (etypecase val
 243           (integer
 244            (if (and (zerop val) (sc-is y any-reg descriptor-reg))
 245                (inst test y y) ; smaller
 246              (let ((fixnumized (fixnumize val)))
 247                (if (typep fixnumized
 248                           '(or (signed-byte 32) (unsigned-byte 31)))
 249                    (inst cmp y fixnumized)
 250                  (progn
 251                    (inst mov temp fixnumized)
 252                    (inst cmp y temp))))))
 253           (symbol
 254            (inst cmp y (+ nil-value (static-symbol-offset val))))
 255           (character
 256            (inst cmp y (logior (ash (char-code val) n-widetag-bits)
 257                                character-widetag))))))
 258       (t
 259        (inst cmp x y)))))
 260
 261 ;; The template above is a very good fallback for the generic
 262 ;; case.  However, it is sometimes possible to perform unboxed
 263 ;; comparisons.  Repurpose char= and eql templates here, instead
 264 ;; of forcing values to be boxed and then compared.
 265 ;;
 266 ;; We only weaken EQL => EQ for characters and fixnums, and detect
 267 ;; when types definitely mismatch.  No need to import other EQL
 268 ;; VOPs (e.g. floats).
 269 (macrolet ((def (eq-name eql-name cost)
 270              `(define-vop (,eq-name ,eql-name)
 271                 (:translate eq)
 272                 (:variant-cost ,cost))))
 273   (def fast-if-eq-character fast-char=/character 3)
 274   (def fast-if-eq-character/c fast-char=/character/c 2)
 275   (def fast-if-eq-fixnum fast-eql/fixnum 3)
 276   (def fast-if-eq-fixnum/c fast-eql-c/fixnum 2)
 277   (def fast-if-eq-signed fast-if-eql/signed 5)
 278   (def fast-if-eq-signed/c fast-if-eql-c/signed 4)
 279   (def fast-if-eq-unsigned fast-if-eql/unsigned 5)
 280   (def fast-if-eq-unsigned/c fast-if-eql-c/unsigned 4))