1 ;;;; x86-64 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 ;;; Space optimization: As the upper 32 bits of (tagged or untagged)
15 ;;; characters are always zero many operations can be done on 32-bit
16 ;;; registers. This often leads to smaller encodings as the REX prefix
17 ;;; is then only needed if registers R8 - R15 are used.
19 ;;;; moves and coercions
21 ;;; Move a tagged char to an untagged representation.
23 (define-vop (move-to-character)
24 (:args
(x :scs
(any-reg descriptor-reg
) :target y
25 :load-if
(not (location= x y
))))
26 (:results
(y :scs
(character-reg)
27 :load-if
(not (location= x y
))))
28 (:note
"character untagging")
30 (cond ((and (sc-is y character-reg
) (sc-is x any-reg descriptor-reg
))
31 (let ((y-dword (make-dword-tn y
)))
32 (unless (location= x y
)
33 (inst mov y-dword
(make-dword-tn x
)))
34 (inst shr y-dword n-widetag-bits
)))
37 (inst shr y n-widetag-bits
)))))
39 (define-vop (move-to-character)
40 (:args
(x :scs
(any-reg control-stack
)))
41 (:results
(y :scs
(character-reg #+nil character-stack
)))
42 (:note
"character untagging")
44 (let ((y-wide-tn (make-random-tn
46 :sc
(sc-or-lose 'any-reg
)
47 :offset
(tn-offset y
))))
49 (inst shr y-wide-tn
8)
50 (inst and y-wide-tn
#xff
))))
51 (define-move-vop move-to-character
:move
52 (any-reg #!-sb-unicode control-stack
)
55 ;;; Move an untagged char to a tagged representation.
57 (define-vop (move-from-character)
58 (:args
(x :scs
(character-reg) :target y
))
59 (:results
(y :scs
(any-reg descriptor-reg
)))
60 (:note
"character tagging")
62 (let ((y-dword (make-dword-tn y
)))
63 (unless (location= x y
)
64 (inst mov y-dword
(make-dword-tn x
)))
65 (inst shl y-dword n-widetag-bits
)
66 (inst or y-dword character-widetag
))))
68 (define-vop (move-from-character)
69 (:args
(x :scs
(character-reg character-stack
)))
70 (:results
(y :scs
(any-reg descriptor-reg
#+nil control-stack
)))
71 (:note
"character tagging")
73 (move (make-random-tn :kind
:normal
:sc
(sc-or-lose 'character-reg
)
74 :offset
(tn-offset y
))
76 (inst shl y n-widetag-bits
)
77 (inst or y character-widetag
)
79 (define-move-vop move-from-character
:move
81 (any-reg descriptor-reg
#!-sb-unicode control-stack
))
83 ;;; Move untagged character values.
84 (define-vop (character-move)
87 :load-if
(not (location= x y
))))
88 (:results
(y :scs
(character-reg character-stack
)
89 :load-if
(not (location= x y
))))
90 (:note
"character move")
95 (define-move-vop character-move
:move
96 (character-reg) (character-reg character-stack
))
98 ;;; Move untagged character arguments/return-values.
99 (define-vop (move-character-arg)
101 :scs
(character-reg))
103 :load-if
(not (sc-is y character-reg
))))
105 (:note
"character arg move")
113 ;; FIXME: naked 8 (should be... what? n-register-bytes?
114 ;; n-word-bytes? Dunno.
115 (make-ea :byte
:base fp
:disp
(- (* (1+ (tn-offset y
)) 8)))
118 (if (= (tn-offset fp
) esp-offset
)
119 (storew x fp
(tn-offset y
)) ; c-call
120 (storew x fp
(- (1+ (tn-offset y
)))))))))
121 (define-move-vop move-character-arg
:move-arg
122 (any-reg character-reg
) (character-reg))
124 ;;; Use standard MOVE-ARG + coercion to move an untagged character
125 ;;; to a descriptor passing location.
126 (define-move-vop move-arg
:move-arg
127 (character-reg) (any-reg descriptor-reg
))
129 ;;;; other operations
131 (define-vop (char-code)
132 (:translate char-code
)
134 (:args
#!-sb-unicode
(ch :scs
(character-reg character-stack
))
135 #!+sb-unicode
(ch :scs
(character-reg character-stack
) :target res
))
136 (:arg-types character
)
137 (:results
(res :scs
(unsigned-reg)))
138 (:result-types positive-fixnum
)
146 (define-vop (code-char)
147 (:translate code-char
)
149 (:args
(code :scs
(unsigned-reg unsigned-stack
) :target res
))
150 (:arg-types positive-fixnum
)
151 (:results
(res :scs
(character-reg)))
152 (:result-types character
)
156 (define-vop (code-char)
157 (:translate code-char
)
159 (:args
(code :scs
(unsigned-reg unsigned-stack
) :target eax
))
160 (:arg-types positive-fixnum
)
161 (:temporary
(:sc unsigned-reg
:offset rax-offset
:target res
162 :from
(:argument
0) :to
(:result
0))
164 (:results
(res :scs
(character-reg)))
165 (:result-types character
)
170 ;;; comparison of CHARACTERs
171 (define-vop (character-compare)
172 (:args
(x :scs
(character-reg character-stack
))
173 (y :scs
(character-reg)
174 :load-if
(not (and (sc-is x character-reg
)
175 (sc-is y character-stack
)))))
176 (:arg-types character character
)
180 (:note
"inline comparison")
181 (:variant-vars condition not-condition
)
184 (inst jmp
(if not-p not-condition condition
) target
)))
186 (define-vop (fast-char=/character character-compare
)
190 (define-vop (fast-char</character character-compare
)
194 (define-vop (fast-char>/character character-compare
)
198 (define-vop (character-compare/c
)
199 (:args
(x :scs
(character-reg character-stack
)))
200 (:arg-types character
(:constant character
))
202 (:info target not-p y
)
204 (:note
"inline constant comparison")
205 (:variant-vars condition not-condition
)
207 (inst cmp x
(sb!xc
:char-code y
))
208 (inst jmp
(if not-p not-condition condition
) target
)))
210 (define-vop (fast-char=/character
/c character-compare
/c
)
214 (define-vop (fast-char</character
/c character-compare
/c
)
218 (define-vop (fast-char>/character
/c character-compare
/c
)