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              ;; XXX: If the sb-unicode case needs to handle c-call,
 107              ;; why does the non-unicode case not need to?
 108              (make-ea :byte :base fp :disp (frame-byte-offset (tn-offset y)))
 109              x)
 110        #!+sb-unicode
 111        (if (= (tn-offset fp) esp-offset)
 112            (storew x fp (tn-offset y))  ; c-call
 113            (storew x fp (frame-word-offset (tn-offset y))))))))
 114 (define-move-vop move-character-arg :move-arg
 115   (any-reg character-reg) (character-reg))
 116
 117 ;;; Use standard MOVE-ARG + coercion to move an untagged character
 118 ;;; to a descriptor passing location.
 119 (define-move-vop move-arg :move-arg
 120   (character-reg) (any-reg descriptor-reg))
 121 \f
 122 ;;;; other operations
 123
 124 (define-vop (char-code)
 125   (:translate char-code)
 126   (:policy :fast-safe)
 127   (:args (ch :scs (character-reg character-stack)))
 128   (:arg-types character)
 129   (:results (res :scs (unsigned-reg)))
 130   (:result-types positive-fixnum)
 131   (:generator 1
 132     #!-sb-unicode
 133     (inst movzx res ch)
 134     #!+sb-unicode
 135     (inst mov res ch)))
 136
 137 #!+sb-unicode
 138 (define-vop (code-char)
 139   (:translate code-char)
 140   (:policy :fast-safe)
 141   (:args (code :scs (unsigned-reg unsigned-stack)))
 142   (:arg-types positive-fixnum)
 143   (:results (res :scs (character-reg)))
 144   (:result-types character)
 145   (:generator 1
 146     (inst mov res code)))
 147 #!-sb-unicode
 148 (define-vop (code-char)
 149   (:translate code-char)
 150   (:policy :fast-safe)
 151   (:args (code :scs (unsigned-reg unsigned-stack) :target eax))
 152   (:arg-types positive-fixnum)
 153   (:temporary (:sc unsigned-reg :offset eax-offset :target res
 154                    :from (:argument 0) :to (:result 0))
 155               eax)
 156   (:results (res :scs (character-reg)))
 157   (:result-types character)
 158   (:generator 1
 159     (move eax code)
 160     (move res al-tn)))
 161 \f
 162 ;;; comparison of CHARACTERs
 163 (define-vop (character-compare)
 164   (:args (x :scs (character-reg character-stack))
 165          (y :scs (character-reg)
 166             :load-if (not (and (sc-is x character-reg)
 167                                (sc-is y character-stack)))))
 168   (:arg-types character character)
 169   (:conditional)
 170   (:info target not-p)
 171   (:policy :fast-safe)
 172   (:note "inline comparison")
 173   (:variant-vars condition not-condition)
 174   (:generator 3
 175     (inst cmp x y)
 176     (inst jmp (if not-p not-condition condition) target)))
 177
 178 (define-vop (fast-char=/character character-compare)
 179   (:translate char=)
 180   (:variant :e :ne))
 181
 182 (define-vop (fast-char</character character-compare)
 183   (:translate char<)
 184   (:variant :b :nb))
 185
 186 (define-vop (fast-char>/character character-compare)
 187   (:translate char>)
 188   (:variant :a :na))
 189
 190 (define-vop (character-compare/c)
 191   (:args (x :scs (character-reg character-stack)))
 192   (:arg-types character (:constant character))
 193   (:conditional)
 194   (:info target not-p y)
 195   (:policy :fast-safe)
 196   (:note "inline constant comparison")
 197   (:variant-vars condition not-condition)
 198   (:generator 2
 199     (inst cmp x (sb!xc:char-code y))
 200     (inst jmp (if not-p not-condition condition) target)))
 201
 202 (define-vop (fast-char=/character/c character-compare/c)
 203   (:translate char=)
 204   (:variant :e :ne))
 205
 206 (define-vop (fast-char</character/c character-compare/c)
 207   (:translate char<)
 208   (:variant :b :nb))
 209
 210 (define-vop (fast-char>/character/c character-compare/c)
 211   (:translate char>)
 212   (:variant :a :na))