src/compiler/alpha/char.lisp

   1 ;;;; the Alpha VM 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 (define-vop (move-to-character)
  18   (:args (x :scs (any-reg descriptor-reg)))
  19   (:results (y :scs (character-reg)))
  20   (:generator 1
  21     (inst srl x n-widetag-bits y)))
  22 (define-move-vop move-to-character :move
  23   (any-reg descriptor-reg) (character-reg))
  24
  25 ;;; Move an untagged char to a tagged representation.
  26 (define-vop (move-from-character)
  27   (:args (x :scs (character-reg)))
  28   (:results (y :scs (any-reg descriptor-reg)))
  29   (:generator 1
  30     (inst sll x n-widetag-bits y)
  31     (inst bis y character-widetag y)))
  32 (define-move-vop move-from-character :move
  33   (character-reg) (any-reg descriptor-reg))
  34
  35 ;;; Move untagged character values.
  36 (define-vop (character-move)
  37   (:args (x :target y
  38             :scs (character-reg)
  39             :load-if (not (location= x y))))
  40   (:results (y :scs (character-reg)
  41                :load-if (not (location= x y))))
  42   (:effects)
  43   (:affected)
  44   (:generator 0
  45     (move x y)))
  46 (define-move-vop character-move :move
  47   (character-reg) (character-reg))
  48
  49 ;;; Move untagged character arguments/return-values.
  50 (define-vop (move-character-arg)
  51   (:args (x :target y
  52             :scs (character-reg))
  53          (fp :scs (any-reg)
  54              :load-if (not (sc-is y character-reg))))
  55   (:results (y))
  56   (:generator 0
  57     (sc-case y
  58       (character-reg
  59        (move x y))
  60       (character-stack
  61        (storew x fp (tn-offset y))))))
  62 (define-move-vop move-character-arg :move-arg
  63   (any-reg character-reg) (character-reg))
  64
  65 ;;; Use standard MOVE-ARG + coercion to move an untagged character
  66 ;;; to a descriptor passing location.
  67 ;;;
  68 (define-move-vop move-arg :move-arg
  69   (character-reg) (any-reg descriptor-reg))
  70 \f
  71 ;;;; other operations
  72 (define-vop (char-code)
  73   (:translate char-code)
  74   (:policy :fast-safe)
  75   (:args (ch :scs (character-reg) :target res))
  76   (:arg-types character)
  77   (:results (res :scs (any-reg)))
  78   (:result-types positive-fixnum)
  79   (:generator 1
  80     (inst sll ch n-fixnum-tag-bits res)))
  81
  82 (define-vop (code-char)
  83   (:translate code-char)
  84   (:policy :fast-safe)
  85   (:args (code :scs (any-reg) :target res))
  86   (:arg-types positive-fixnum)
  87   (:results (res :scs (character-reg)))
  88   (:result-types character)
  89   (:generator 1
  90     (inst srl code n-fixnum-tag-bits res)))
  91 \f
  92 ;;;; comparison of CHARACTERs
  93
  94 (define-vop (character-compare)
  95   (:args (x :scs (character-reg))
  96          (y :scs (character-reg)))
  97   (:arg-types character character)
  98   (:temporary (:scs (non-descriptor-reg)) temp)
  99   (:conditional)
 100   (:info target not-p)
 101   (:policy :fast-safe)
 102   (:note "inline comparison")
 103   (:variant-vars cond)
 104   (:generator 3
 105     (ecase cond
 106       (:eq (inst cmpeq x y temp))
 107       (:lt (inst cmplt x y temp))
 108       (:gt (inst cmplt y x temp)))
 109     (if not-p
 110         (inst beq temp target)
 111         (inst bne temp target))))
 112
 113 (define-vop (fast-char=/character character-compare)
 114   (:translate char=)
 115   (:variant :eq))
 116
 117 (define-vop (fast-char</character character-compare)
 118   (:translate char<)
 119   (:variant :lt))
 120
 121 (define-vop (fast-char>/character character-compare)
 122   (:translate char>)
 123   (:variant :gt))
 124
 125 (define-vop (character-compare/c)
 126   (:args (x :scs (character-reg)))
 127   (:arg-types character (:constant character))
 128   (:temporary (:scs (non-descriptor-reg)) temp)
 129   (:conditional)
 130   (:info target not-p y)
 131   (:policy :fast-safe)
 132   (:note "inline constant comparison")
 133   (:variant-vars cond)
 134   (:generator 2
 135     (ecase cond
 136       (:eq (inst cmpeq x (sb!xc:char-code y) temp))
 137       (:lt (inst cmplt x (sb!xc:char-code y) temp))
 138       (:gt (inst cmple x (sb!xc:char-code y) temp)))
 139     (if not-p
 140         (if (eq cond :gt)
 141             (inst bne temp target)
 142             (inst beq temp target))
 143         (if (eq cond :gt)
 144             (inst beq temp target)
 145             (inst bne temp target)))))
 146
 147 (define-vop (fast-char=/character/c character-compare/c)
 148   (:translate char=)
 149   (:variant :eq))
 150
 151 (define-vop (fast-char</character/c character-compare/c)
 152   (:translate char<)
 153   (:variant :lt))
 154
 155 (define-vop (fast-char>/character/c character-compare/c)
 156   (:translate char>)
 157   (:variant :gt))