0.9.2.43:
[sbcl.git] / 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))