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.
22 ;;; The best possible instruction sequences for various X and Y SC's are:
23 ;;; * reg-to-reg: dword move, then shift
24 ;;; * reg-to-mem: dword move to temp, shift temp, store as qword
25 ;;; * mem-to-reg: misaligned dword load (read 4 bytes at byte index 1)
26 ;;; * mem-to-mem: misaligned dword load to temp, store as a qword
28 ;;; Since there's no such thing as a 3-byte load, the misaligned loads
29 ;;; overrun a naturally aligned :dword within the :qword, but that's fine.
30 ;;; However, we can't actually implement that because we lack a way to
31 ;;; create an arbitrary EA given a stack TN. So, instead do:
32 ;;; * mem-to-reg: dword load, shift
33 ;;; * mem-to-mem: dword load to temp, shift temp, store as a qword
34 (defun untagify-char (dst src shift temp
)
35 (if (and (location= src dst
) (stack-tn-p dst
)) ; shift right in memory
36 (inst shr
:dword dst shift
)
37 (let ((reg (if (stack-tn-p dst
) temp dst
)))
39 (inst shr
:dword reg shift
)
40 (when (stack-tn-p dst
) ; store as qword to ensure upper bytes are 0
41 (inst mov dst temp
)))))
42 (define-vop (move-to-character)
43 (:args
(x :scs
(any-reg descriptor-reg control-stack
) :target y
:load-if nil
))
44 (:results
(y :scs
(character-reg character-stack
) :load-if nil
))
45 (:temporary
(:sc unsigned-reg
) temp
)
46 (:note
"character untagging")
47 (:generator
1 (untagify-char y x n-widetag-bits temp
)))
48 (define-move-vop move-to-character
:move
52 ;;; Move a tagged character in an {ANY|DESCRIPTOR}-REG or control stack
53 ;;; to a fixnum in those same SCs. This is untaggeding and fixnumizing
54 ;;; in one right shift, not a right + left shift.
55 ;;; ASSUMPTION: the topmost bit in character-widetag is 0
56 (eval-when (:compile-toplevel
) ; Verify assumption.
57 (assert (not (logbitp 7 character-widetag
))))
58 (define-vop (tagged-char-code) ; valid only if N-FIXNUM-TAG-BITS = 1
59 (:args
(x :scs
(any-reg descriptor-reg control-stack
) :target y
:load-if nil
))
60 (:results
(y :scs
(any-reg descriptor-reg control-stack
) :load-if nil
))
61 (:temporary
(:sc unsigned-reg
) temp
)
62 (:note
"character untagging")
64 (untagify-char y x
(- n-widetag-bits n-fixnum-tag-bits
) temp
)
65 (when (> n-fixnum-tag-bits
1) (inst and
:dword y fixnum-tag-mask
))))
67 ;;; Move an untagged char to a tagged representation.
68 (define-vop (move-from-character)
69 (:args
(x :scs
(character-reg) :target y
))
70 (:results
(y :scs
(any-reg descriptor-reg
)))
71 (:note
"character tagging")
74 (inst shl
:dword y n-widetag-bits
)
75 (inst or
:dword y character-widetag
)))
76 (define-move-vop move-from-character
:move
78 (any-reg descriptor-reg
))
80 ;;; Move untagged character values.
81 (defun move-raw-char-code (dst src temp
) ; move SRC to DST
82 (unless (location= src dst
)
83 ;; Aways store as :qword to stack (storing the upper 32 zero bits) so that
84 ;; loading as either :dword or :qword is ok.
85 ;; We can see immediate constants here which become untagged integers.
86 (inst mov
(if (stack-tn-p dst
) :qword
:dword
) dst
87 (cond ((stack-tn-p src
) (inst mov
:qword temp src
) temp
)
88 ((encode-value-if-immediate src nil
))))))
89 (define-vop (character-move)
90 (:args
(x :target y
:scs
(character-reg character-stack
) :load-if nil
))
91 (:results
(y :scs
(character-reg character-stack
) :load-if nil
))
92 (:temporary
(:sc unsigned-reg
) temp
)
93 (:note
"character move")
94 (:generator
0 (move-raw-char-code y x temp
)))
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")
111 (if (= (tn-offset fp
) rsp-offset
)
112 (storew x fp
(tn-offset y
)) ; c-call
113 (storew x fp
(frame-word-offset (tn-offset y
))))))))
114 (define-move-vop move-character-arg
:move-arg
115 (any-reg character-reg
) (character-reg))
117 ;;; Use standard MOVE-ARG + coercion to move an untagged character
118 ;;; to a descriptor passing location.
119 (define-move-vop move-arg
:move-arg
120 (character-reg) (any-reg descriptor-reg
))
122 ;;;; other operations
124 (define-vop (char-code)
125 (:translate char-code
)
127 (:args
(ch :scs
(character-reg character-stack
) :target res
:load-if nil
))
128 (:arg-types character
)
129 (:results
(res :scs
(unsigned-reg unsigned-stack
) :load-if nil
))
130 (:result-types positive-fixnum
)
131 (:temporary
(:sc unsigned-reg
) temp
)
132 (:generator
1 (move-raw-char-code res ch temp
)))
134 (define-vop (code-char)
135 (:translate code-char
)
137 (:args
(code :scs
(unsigned-reg unsigned-stack
) :target res
:load-if nil
))
138 (:arg-types positive-fixnum
)
139 (:results
(res :scs
(character-reg character-stack
) :load-if nil
))
140 (:result-types character
)
141 (:temporary
(:sc unsigned-reg
) temp
)
142 (:generator
1 (move-raw-char-code res code temp
)))
144 ;;; comparison of CHARACTERs
145 (define-vop (character-compare)
146 (:args
(x :scs
(character-reg character-stack
))
147 (y :scs
(character-reg)
148 :load-if
(not (and (sc-is x character-reg
)
149 (sc-is y character-stack
)))))
150 (:arg-types character character
)
153 (:note
"inline comparison")
155 (inst cmp
:dword x y
)))
157 (define-vop (fast-char=/character character-compare
)
161 (define-vop (fast-char</character character-compare
)
165 (define-vop (fast-char>/character character-compare
)
169 (define-vop (character-compare/c
)
170 (:args
(x :scs
(character-reg character-stack
)))
171 (:arg-types character
(:constant character
))
174 (:note
"inline constant comparison")
176 (inst cmp
:dword x
(char-code y
))))
178 (define-vop (fast-char=/character
/c character-compare
/c
)
182 (define-vop (fast-char</character
/c character-compare
/c
)
186 (define-vop (fast-char>/character
/c character-compare
/c
)
191 (define-vop (base-char-p)
192 (:args
(value :scs
(any-reg descriptor-reg
)))
194 (:translate base-char-p
)
195 (:temporary
(:sc unsigned-reg
:from
(:argument
0)) temp
)
197 (:save-p
:compute-only
)
200 (inst lea
:dword temp
(ea (- character-widetag
) value
))
201 (inst test
:dword temp
(lognot #x7F00
))))
204 (define-vop (base-char-p-character)
205 (:args
(value :scs
(any-reg)))
206 (:arg-types character
)
207 (:translate base-char-p
)
209 (:save-p
:compute-only
)
212 (inst test
:dword value
(lognot #x7FFF
))))
215 (define-vop (base-char-p-character-reg)
216 (:args
(value :scs
(character-reg)))
217 (:arg-types character
)
218 (:translate base-char-p
)
220 (:save-p
:compute-only
)
223 (inst cmp
:dword value base-char-code-limit
)))
225 ;;; Replace the triple (MOVE-TO-CHARACTER CHAR-CODE MOVE-FROM-WORD/FIXNUM)
226 ;;; with just the TAGGED-CHAR-CODE vop.
227 (defoptimizer (sb-c::vop-optimize move-to-character
) (vop)
228 (when (and (sb-c:next-vop-is vop
'char-code
)
229 (sb-c:next-vop-is
(sb-c::next-vop vop
) 'move-from-word
/fixnum
))
230 (sb-c:replace-vops
3 vop
'tagged-char-code
)))