1.0.1.18:
[sbcl.git] / src / compiler / hppa / char.lisp
1 ;;;; the HPPA 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 addi character-widetag y 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 args/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 to
66 ;;; a descriptor passing location.
67 (define-move-vop move-arg :move-arg
68   (character-reg) (any-reg descriptor-reg))
69 \f
70 ;;;; Other operations:
71 (define-vop (char-code)
72   (:translate char-code)
73   (:policy :fast-safe)
74   (:args (ch :scs (character-reg) :target res))
75   (:arg-types character)
76   (:results (res :scs (unsigned-reg)))
77   (:result-types positive-fixnum)
78   (:generator 1
79     (move ch res)))
80
81 (define-vop (code-char)
82   (:translate code-char)
83   (:policy :fast-safe)
84   (:args (code :scs (unsigned-reg) :target res))
85   (:arg-types positive-fixnum)
86   (:results (res :scs (character-reg)))
87   (:result-types character)
88   (:generator 1
89     (move code res)))
90 \f
91 ;;; Comparison of characters.
92 (define-vop (character-compare)
93   (:args (x :scs (character-reg))
94          (y :scs (character-reg)))
95   (:arg-types character character)
96   (:conditional)
97   (:info target not-p)
98   (:policy :fast-safe)
99   (:note "inline comparison")
100   (:variant-vars cond)
101   (:generator 3
102     (inst bc cond not-p x y target)))
103
104 (define-vop (fast-char=/character character-compare)
105   (:translate char=)
106   (:variant :=))
107
108 (define-vop (fast-char</character character-compare)
109   (:translate char<)
110   (:variant :<<))
111
112 (define-vop (fast-char>/character character-compare)
113   (:translate char>)
114   (:variant :>>))