src/compiler/x86/char.lisp

   1 ;;;; x86 definition of character operations
   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 ;;;; moves and coercions
  15
  16 ;;; Move a tagged char to an untagged representation.
  17 #!+sb-unicode
  18 (define-vop (move-to-character)
  19   (:args (x :scs (any-reg descriptor-reg) :target y
  20             :load-if (not (location= x y))))
  21   (:results (y :scs (character-reg)
  22                :load-if (not (location= x y))))
  23   (:note "character untagging")
  24   (:generator 1
  25     (move y x)
  26     (inst shr y n-widetag-bits)))
  27 #!-sb-unicode
  28 (define-vop (move-to-character)
  29   (:args (x :scs (any-reg control-stack) :target al))
  30   (:temporary (:sc byte-reg :offset al-offset
  31                    :from (:argument 0) :to (:eval 0)) al)
  32   (:ignore al)
  33   (:temporary (:sc byte-reg :offset ah-offset :target y
  34                    :from (:argument 0) :to (:result 0)) ah)
  35   (:results (y :scs (character-reg character-stack)))
  36   (:note "character untagging")
  37   (:generator 1
  38     (move eax-tn x)
  39     (move y ah)))
  40 (define-move-vop move-to-character :move
  41   (any-reg #!-sb-unicode control-stack)
  42   (character-reg #!-sb-unicode character-stack))
  43
  44 ;;; Move an untagged char to a tagged representation.
  45 #!+sb-unicode
  46 (define-vop (move-from-character)
  47   (:args (x :scs (character-reg)))
  48   (:results (y :scs (any-reg descriptor-reg)))
  49   (:note "character tagging")
  50   (:generator 1
  51     ;; FIXME: is this inefficient?  Is there a better way of writing
  52     ;; it?  (fixnum tagging is done with LEA).  We can't use SHL
  53     ;; because we either scribble over the source register or briefly
  54     ;; have a non-descriptor in a descriptor register, unless we
  55     ;; introduce a temporary.
  56     (inst imul y x (ash 1 n-widetag-bits))
  57     (inst or y character-widetag)))
  58 #!-sb-unicode
  59 (define-vop (move-from-character)
  60   (:args (x :scs (character-reg character-stack) :target ah))
  61   (:temporary (:sc byte-reg :offset al-offset :target y
  62                    :from (:argument 0) :to (:result 0)) al)
  63   (:temporary (:sc byte-reg :offset ah-offset
  64                    :from (:argument 0) :to (:result 0)) ah)
  65   (:results (y :scs (any-reg descriptor-reg control-stack)))
  66   (:note "character tagging")
  67   (:generator 1
  68     (move ah x)                         ; Maybe move char byte.
  69     (inst mov al character-widetag)     ; x86 to type bits
  70     (inst and eax-tn #xffff)            ; Remove any junk bits.
  71     (move y eax-tn)))
  72 (define-move-vop move-from-character :move
  73   (character-reg #!-sb-unicode character-stack)
  74   (any-reg descriptor-reg #!-sb-unicode control-stack))
  75
  76 ;;; Move untagged character values.
  77 (define-vop (character-move)
  78   (:args (x :target y
  79             :scs (character-reg)
  80             :load-if (not (location= x y))))
  81   (:results (y :scs (character-reg character-stack)
  82                :load-if (not (location= x y))))
  83   (:note "character move")
  84   (:effects)
  85   (:affected)
  86   (:generator 0
  87     (move y x)))
  88 (define-move-vop character-move :move
  89   (character-reg) (character-reg character-stack))
  90
  91 ;;; Move untagged character arguments/return-values.
  92 (define-vop (move-character-arg)
  93   (:args (x :target y
  94             :scs (character-reg))
  95          (fp :scs (any-reg)
  96              :load-if (not (sc-is y character-reg))))
  97   (:results (y))
  98   (:note "character arg move")
  99   (:generator 0
 100     (sc-case y
 101       (character-reg
 102        (move y x))
 103       (character-stack
 104        #!-sb-unicode
 105        (inst mov
 106              (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) 4)))
 107              x)
 108        #!+sb-unicode
 109        (if (= (tn-offset fp) esp-offset)
 110            (storew x fp (tn-offset y))  ; c-call
 111            (storew x fp (- (1+ (tn-offset y)))))))))
 112 (define-move-vop move-character-arg :move-arg
 113   (any-reg character-reg) (character-reg))
 114
 115 ;;; Use standard MOVE-ARG + coercion to move an untagged character
 116 ;;; to a descriptor passing location.
 117 (define-move-vop move-arg :move-arg
 118   (character-reg) (any-reg descriptor-reg))
 119 \f
 120 ;;;; other operations
 121
 122 (define-vop (char-code)
 123   (:translate char-code)
 124   (:policy :fast-safe)
 125   (:args (ch :scs (character-reg character-stack)))
 126   (:arg-types character)
 127   (:results (res :scs (unsigned-reg)))
 128   (:result-types positive-fixnum)
 129   (:generator 1
 130     #!-sb-unicode
 131     (inst movzx res ch)
 132     #!+sb-unicode
 133     (inst mov res ch)))
 134
 135 #!+sb-unicode
 136 (define-vop (code-char)
 137   (:translate code-char)
 138   (:policy :fast-safe)
 139   (:args (code :scs (unsigned-reg unsigned-stack)))
 140   (:arg-types positive-fixnum)
 141   (:results (res :scs (character-reg)))
 142   (:result-types character)
 143   (:generator 1
 144     (inst mov res code)))
 145 #!-sb-unicode
 146 (define-vop (code-char)
 147   (:translate code-char)
 148   (:policy :fast-safe)
 149   (:args (code :scs (unsigned-reg unsigned-stack) :target eax))
 150   (:arg-types positive-fixnum)
 151   (:temporary (:sc unsigned-reg :offset eax-offset :target res
 152                    :from (:argument 0) :to (:result 0))
 153               eax)
 154   (:results (res :scs (character-reg)))
 155   (:result-types character)
 156   (:generator 1
 157     (move eax code)
 158     (move res al-tn)))
 159 \f
 160 ;;; comparison of CHARACTERs
 161 (define-vop (character-compare)
 162   (:args (x :scs (character-reg character-stack))
 163          (y :scs (character-reg)
 164             :load-if (not (and (sc-is x character-reg)
 165                                (sc-is y character-stack)))))
 166   (:arg-types character character)
 167   (:conditional)
 168   (:info target not-p)
 169   (:policy :fast-safe)
 170   (:note "inline comparison")
 171   (:variant-vars condition not-condition)
 172   (:generator 3
 173     (inst cmp x y)
 174     (inst jmp (if not-p not-condition condition) target)))
 175
 176 (define-vop (fast-char=/character character-compare)
 177   (:translate char=)
 178   (:variant :e :ne))
 179
 180 (define-vop (fast-char</character character-compare)
 181   (:translate char<)
 182   (:variant :b :nb))
 183
 184 (define-vop (fast-char>/character character-compare)
 185   (:translate char>)
 186   (:variant :a :na))
 187
 188 (define-vop (character-compare/c)
 189   (:args (x :scs (character-reg character-stack)))
 190   (:arg-types character (:constant character))
 191   (:conditional)
 192   (:info target not-p y)
 193   (:policy :fast-safe)
 194   (:note "inline constant comparison")
 195   (:variant-vars condition not-condition)
 196   (:generator 2
 197     (inst cmp x (sb!xc:char-code y))
 198     (inst jmp (if not-p not-condition condition) target)))
 199
 200 (define-vop (fast-char=/character/c character-compare/c)
 201   (:translate char=)
 202   (:variant :e :ne))
 203
 204 (define-vop (fast-char</character/c character-compare/c)
 205   (:translate char<)
 206   (:variant :b :nb))
 207
 208 (define-vop (fast-char>/character/c character-compare/c)
 209   (:translate char>)
 210   (:variant :a :na))