src/compiler/ppc/char.lisp

   1 ;;;; the PPC 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   (:note "character untagging")
  21   (:generator 1
  22     (inst srwi y x n-widetag-bits)))
  23 (define-move-vop move-to-character :move
  24   (any-reg descriptor-reg) (character-reg))
  25
  26 ;;; Move an untagged char to a tagged representation.
  27 (define-vop (move-from-character)
  28   (:args (x :scs (character-reg)))
  29   (:results (y :scs (any-reg descriptor-reg)))
  30   (:note "character tagging")
  31   (:generator 1
  32     (inst slwi y x n-widetag-bits)
  33     (inst ori y y character-widetag)))
  34 (define-move-vop move-from-character :move
  35   (character-reg) (any-reg descriptor-reg))
  36
  37 ;;; Move untagged character values.
  38 (define-vop (character-move)
  39   (:args (x :target y
  40             :scs (character-reg)
  41             :load-if (not (location= x y))))
  42   (:results (y :scs (character-reg)
  43                :load-if (not (location= x y))))
  44   (:note "character move")
  45   (:effects)
  46   (:affected)
  47   (:generator 0
  48     (move y x)))
  49 (define-move-vop character-move :move
  50   (character-reg) (character-reg))
  51
  52 ;;; Move untagged character arguments/return-values.
  53 (define-vop (move-character-arg)
  54   (:args (x :target y
  55             :scs (character-reg))
  56          (fp :scs (any-reg)
  57              :load-if (not (sc-is y character-reg))))
  58   (:results (y))
  59   (:note "character arg move")
  60   (:generator 0
  61     (sc-case y
  62       (character-reg
  63        (move y x))
  64       (character-stack
  65        (storew x fp (tn-offset y))))))
  66 (define-move-vop move-character-arg :move-arg
  67   (any-reg character-reg) (character-reg))
  68
  69 ;;; Use standard MOVE-ARG + coercion to move an untagged character
  70 ;;; to a descriptor passing location.
  71 (define-move-vop move-arg :move-arg
  72   (character-reg) (any-reg descriptor-reg))
  73 \f
  74 ;;;; Other operations:
  75
  76 (define-vop (char-code)
  77   (:translate char-code)
  78   (:policy :fast-safe)
  79   (:args (ch :scs (character-reg) :target res))
  80   (:arg-types character)
  81   (:results (res :scs (any-reg)))
  82   (:result-types positive-fixnum)
  83   (:generator 1
  84     (inst slwi res ch n-fixnum-tag-bits)))
  85
  86 (define-vop (code-char)
  87   (:translate code-char)
  88   (:policy :fast-safe)
  89   (:args (code :scs (any-reg) :target res))
  90   (:arg-types positive-fixnum)
  91   (:results (res :scs (character-reg)))
  92   (:result-types character)
  93   (:generator 1
  94     (inst srwi res code n-fixnum-tag-bits)))
  95 \f
  96 ;;; Comparison of characters.
  97 (define-vop (character-compare)
  98   (:args (x :scs (character-reg))
  99          (y :scs (character-reg)))
 100   (:arg-types character character)
 101   (:conditional)
 102   (:info target not-p)
 103   (:policy :fast-safe)
 104   (:note "inline comparison")
 105   (:variant-vars condition not-condition)
 106   (:generator 3
 107     (inst cmplw x y)
 108     (inst b? (if not-p not-condition condition) target)))
 109
 110 (define-vop (fast-char=/character character-compare)
 111   (:translate char=)
 112   (:variant :eq :ne))
 113
 114 (define-vop (fast-char</character character-compare)
 115   (:translate char<)
 116   (:variant :lt :ge))
 117
 118 (define-vop (fast-char>/character character-compare)
 119   (:translate char>)
 120   (:variant :gt :le))
 121
 122 (define-vop (character-compare/c)
 123   (:args (x :scs (character-reg)))
 124   (:arg-types character
 125               ;; KLUDGE: having a SATISFIES type here is too hairy for
 126               ;; the cross-compiler (running on an arbitrary CL host)
 127               ;; to cope with.  Since we know we only have standard
 128               ;; characters in the build anyway, we can restrict the
 129               ;; cross-compiler's arg type to standard char, and all
 130               ;; is well.
 131               #+sb-xc-host
 132               (:constant standard-char)
 133               #-sb-xc-host
 134               (:constant (satisfies inlinable-character-constant-p)))
 135   (:conditional)
 136   (:info target not-p y)
 137   (:policy :fast-safe)
 138   (:note "inline comparison")
 139   (:variant-vars condition not-condition)
 140   (:generator 2
 141     (inst cmplwi x (sb!xc:char-code y))
 142     (inst b? (if not-p not-condition condition) target)))
 143
 144 (define-vop (fast-char=/character/c character-compare/c)
 145   (:translate char=)
 146   (:variant :eq :ne))
 147
 148 (define-vop (fast-char</character/c character-compare/c)
 149   (:translate char<)
 150   (:variant :lt :ge))
 151
 152 (define-vop (fast-char>/character/c character-compare/c)
 153   (:translate char>)
 154   (:variant :gt :le))