1 ;;;; x86 definition of character operations
3 ;;;; This software is part of the SBCL system. See the README file for
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.
14 ;;;; moves and coercions
16 ;;; Move a tagged char to an untagged representation.
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")
26 (inst shr y n-widetag-bits
)))
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
)
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")
40 (define-move-vop move-to-character
:move
41 (any-reg #!-sb-unicode control-stack
)
42 (character-reg #!-sb-unicode character-stack
))
44 ;;; Move an untagged char to a tagged representation.
46 (define-vop (move-from-character)
47 (:args
(x :scs
(character-reg) :target y
))
48 (:results
(y :scs
(any-reg descriptor-reg
)))
49 (:note
"character tagging")
52 (inst shl y n-widetag-bits
)
53 (inst or y character-widetag
)))
55 (define-vop (move-from-character)
56 (:args
(x :scs
(character-reg character-stack
) :target ah
))
57 (:temporary
(:sc byte-reg
:offset al-offset
:target y
58 :from
(:argument
0) :to
(:result
0)) al
)
59 (:temporary
(:sc byte-reg
:offset ah-offset
60 :from
(:argument
0) :to
(:result
0)) ah
)
61 (:results
(y :scs
(any-reg descriptor-reg control-stack
)))
62 (:note
"character tagging")
64 (move ah x
) ; Maybe move char byte.
65 (inst mov al character-widetag
) ; x86 to type bits
66 (inst and eax-tn
#xffff
) ; Remove any junk bits.
68 (define-move-vop move-from-character
:move
69 (character-reg #!-sb-unicode character-stack
)
70 (any-reg descriptor-reg
#!-sb-unicode control-stack
))
72 ;;; Move untagged character values.
73 (define-vop (character-move)
76 :load-if
(not (location= x y
))))
77 (:results
(y :scs
(character-reg character-stack
)
78 :load-if
(not (location= x y
))))
79 (:note
"character move")
84 (define-move-vop character-move
:move
85 (character-reg) (character-reg character-stack
))
87 ;;; Move untagged character arguments/return-values.
88 (define-vop (move-character-arg)
92 :load-if
(not (sc-is y character-reg
))))
94 (:note
"character arg move")
102 ;; XXX: If the sb-unicode case needs to handle c-call,
103 ;; why does the non-unicode case not need to?
104 (make-ea :byte
:base fp
:disp
(frame-byte-offset (tn-offset y
)))
107 (if (= (tn-offset fp
) esp-offset
)
108 (storew x fp
(tn-offset y
)) ; c-call
109 (storew x fp
(frame-word-offset (tn-offset y
))))))))
110 (define-move-vop move-character-arg
:move-arg
111 (any-reg character-reg
) (character-reg))
113 ;;; Use standard MOVE-ARG + coercion to move an untagged character
114 ;;; to a descriptor passing location.
115 (define-move-vop move-arg
:move-arg
116 (character-reg) (any-reg descriptor-reg
))
118 ;;;; other operations
120 (define-vop (char-code)
121 (:translate char-code
)
123 (:args
#!-sb-unicode
(ch :scs
(character-reg character-stack
))
124 #!+sb-unicode
(ch :scs
(character-reg character-stack
) :target res
))
125 (:arg-types character
)
126 (:results
(res :scs
(unsigned-reg)))
127 (:result-types positive-fixnum
)
135 (define-vop (code-char)
136 (:translate code-char
)
138 (:args
(code :scs
(unsigned-reg unsigned-stack
) :target res
))
139 (:arg-types positive-fixnum
)
140 (:results
(res :scs
(character-reg)))
141 (:result-types character
)
145 (define-vop (code-char)
146 (:translate code-char
)
148 (:args
(code :scs
(unsigned-reg unsigned-stack
) :target eax
))
149 (:arg-types positive-fixnum
)
150 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target res
151 :from
(:argument
0) :to
(:result
0))
153 (:results
(res :scs
(character-reg)))
154 (:result-types character
)
159 ;;; comparison of CHARACTERs
160 (define-vop (character-compare)
161 (:args
(x :scs
(character-reg character-stack
))
162 (y :scs
(character-reg)
163 :load-if
(not (and (sc-is x character-reg
)
164 (sc-is y character-stack
)))))
165 (:arg-types character character
)
167 (:note
"inline comparison")
171 (define-vop (fast-char=/character character-compare
)
175 (define-vop (fast-char</character character-compare
)
179 (define-vop (fast-char>/character character-compare
)
183 (define-vop (character-compare/c
)
184 (:args
(x :scs
(character-reg character-stack
)))
185 (:arg-types character
(:constant character
))
188 (:note
"inline constant comparison")
190 (inst cmp x
(sb!xc
:char-code y
))))
192 (define-vop (fast-char=/character
/c character-compare
/c
)
196 (define-vop (fast-char</character
/c character-compare
/c
)
200 (define-vop (fast-char>/character
/c character-compare
/c
)