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               (mapcar (if (and vop sc)
  55                           (lambda (ptype)
  56                             (list ptype sc vop))
  57                           #'list)
  58                       (ensure-list ptypes))))
  59           '((t descriptor-reg move-if/t)
  60
  61             ((fixnum positive-fixnum)
  62              any-reg move-if/fx)
  63             ((unsigned-byte-32 unsigned-byte-31)
  64              unsigned-reg move-if/unsigned)
  65             (signed-byte-32 signed-reg move-if/signed)
  66             ;; FIXME: Can't use CMOV with byte registers, and characters live
  67             ;; in such outside of unicode builds. A better solution then just
  68             ;; disabling MOVE-IF/CHAR should be possible, though.
  69             #!+sb-unicode
  70             (character character-reg move-if/char)
  71
  72             ((single-float complex-single-float
  73               double-float complex-double-float))
  74
  75             (system-area-pointer sap-reg move-if/sap)))
  76   "Alist of primitive type -> (storage-class-name VOP-name)
  77    if values of such a type should be cmoved, and NIL otherwise.
  78
  79    storage-class-name is the name of the storage class to use for
  80    the values, and VOP-name the name of the VOP that will be used
  81    to execute the conditional move.")
  82
  83 (defun convert-conditional-move-p (node dst-tn x-tn y-tn)
  84   (declare (ignore node))
  85   (let* ((ptype (sb!c::tn-primitive-type dst-tn))
  86          (name  (sb!c::primitive-type-name ptype))
  87          (param (and (memq :cmov *backend-subfeatures*)
  88                      (cdr (or (assoc name *cmov-ptype-representation-vop*)
  89                               '(t descriptor-reg move-if/t))))))
  90     (when param
  91       (destructuring-bind (representation vop) param
  92         (let ((scn (sc-number-or-lose representation)))
  93           (labels ((make-tn ()
  94                      (make-representation-tn ptype scn))
  95                    (frob-tn (tn)
  96                      (if (immediate-tn-p tn)
  97                          tn
  98                          (make-tn))))
  99             (values vop
 100                     (frob-tn x-tn) (frob-tn y-tn)
 101                     (make-tn)
 102                     nil)))))))
 103
 104 (define-vop (move-if)
 105   (:args (then) (else))
 106   (:temporary (:sc unsigned-reg :from :eval) temp)
 107   (:results (res))
 108   (:info flags)
 109   (:generator 0
 110      (flet ((load-immediate (dst constant-tn
 111                                  &optional (sc (sc-name (tn-sc dst))))
 112               (let ((val (tn-value constant-tn)))
 113                 (etypecase val
 114                   (integer
 115                      (if (memq sc '(any-reg descriptor-reg))
 116                          (inst mov dst (fixnumize val))
 117                          (inst mov dst val)))
 118                   (symbol
 119                      (aver (eq sc 'descriptor-reg))
 120                      (load-symbol dst val))
 121                   (character
 122                      (cond ((memq sc '(any-reg descriptor-reg))
 123                             (inst mov dst
 124                                   (logior (ash (char-code val) n-widetag-bits)
 125                                           character-widetag)))
 126                            (t
 127                             (aver (eq sc 'character-reg))
 128                             (inst mov dst (char-code val)))))))))
 129        (aver (null (rest flags)))
 130        (if (sc-is else immediate)
 131            (load-immediate res else)
 132            (move res else))
 133        (when (sc-is then immediate)
 134          (load-immediate temp then (sc-name (tn-sc res)))
 135          (setf then temp))
 136        (inst cmov (first flags) res then))))
 137
 138 (macrolet ((def-move-if (name type reg stack)
 139                `(define-vop (,name move-if)
 140                   (:args (then :scs (immediate ,reg ,stack) :to :eval
 141                                :target temp
 142                                :load-if (not (or (sc-is then immediate)
 143                                                  (and (sc-is then ,stack)
 144                                                       (not (location= else res))))))
 145                          (else :scs (immediate ,reg ,stack) :target res
 146                                :load-if (not (sc-is else immediate ,stack))))
 147                   (:arg-types ,type ,type)
 148                   (:results (res :scs (,reg)
 149                                  :from (:argument 1)))
 150                   (:result-types ,type))))
 151   (def-move-if move-if/t t descriptor-reg control-stack)
 152   (def-move-if move-if/fx tagged-num any-reg control-stack)
 153   (def-move-if move-if/unsigned unsigned-num unsigned-reg unsigned-stack)
 154   (def-move-if move-if/signed signed-num signed-reg signed-stack)
 155   ;; FIXME: See *CMOV-PTYPE-REPRESENTATION-VOP* above.
 156   #!+sb-unicode
 157   (def-move-if move-if/char character character-reg character-stack)
 158   (def-move-if move-if/sap system-area-pointer sap-reg sap-stack))
 159
 160 \f
 161 ;;;; conditional VOPs
 162
 163 ;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement,
 164 ;;; not immediate data.
 165 (define-vop (if-eq)
 166   (:args (x :scs (any-reg descriptor-reg control-stack constant)
 167             :load-if (not (and (sc-is x immediate)
 168                                (sc-is y any-reg descriptor-reg
 169                                       control-stack constant))))
 170          (y :scs (any-reg descriptor-reg immediate)
 171             :load-if (not (and (sc-is x any-reg descriptor-reg immediate)
 172                                (sc-is y control-stack constant)))))
 173   (:conditional :e)
 174   (:info)
 175   (:policy :fast-safe)
 176   (:translate eq)
 177   (:generator 6
 178     (let ((x-val (encode-value-if-immediate x))
 179           (y-val (encode-value-if-immediate y)))
 180       (cond
 181         ;; Shorter instruction sequences for these two cases.
 182         ((and (eql 0 y-val) (sc-is x any-reg descriptor-reg)) (inst test x x))
 183         ((and (eql 0 x-val) (sc-is y any-reg descriptor-reg)) (inst test y y))
 184
 185         ;; An encoded value (literal integer) has to be the second argument.
 186         ((sc-is x immediate) (inst cmp y x-val))
 187
 188         (t (inst cmp x y-val))))))
 189
 190 (macrolet ((def (eq-name eql-name cost)
 191              `(define-vop (,eq-name ,eql-name)
 192                 (:translate eq)
 193                 (:variant-cost ,cost))))
 194   (def fast-if-eq-character fast-char=/character 3)
 195   (def fast-if-eq-character/c fast-char=/character/c 2)
 196   (def fast-if-eq-fixnum fast-eql/fixnum 3)
 197   (def fast-if-eq-fixnum/c fast-eql-c/fixnum 2)
 198   (def fast-if-eq-signed fast-if-eql/signed 5)
 199   (def fast-if-eq-signed/c fast-if-eql-c/signed 4)
 200   (def fast-if-eq-unsigned fast-if-eql/unsigned 5)
 201   (def fast-if-eq-unsigned/c fast-if-eql-c/unsigned 4))