X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fchar.lisp;h=b70458c3af85d118ecb681987cd1f7cf634a3bcc;hb=d306e2d23b38487488eb93881dad836e439e0c77;hp=bbd1fa47efb0b33997caffe37a5cf67defa98b7c;hpb=78fa16bf55be44cc16845be84d98023e83fb14bc;p=sbcl.git diff --git a/src/compiler/x86-64/char.lisp b/src/compiler/x86-64/char.lisp index bbd1fa4..b70458c 100644 --- a/src/compiler/x86-64/char.lisp +++ b/src/compiler/x86-64/char.lisp @@ -1,4 +1,4 @@ -;;;; x86 definition of character operations +;;;; x86-64 definition of character operations ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -11,19 +11,30 @@ (in-package "SB!VM") +;;; Space optimization: As the upper 32 bits of (tagged or untagged) +;;; characters are always zero many operations can be done on 32-bit +;;; registers. This often leads to smaller encodings as the REX prefix +;;; is then only needed if registers R8 - R15 are used. + ;;;; moves and coercions ;;; Move a tagged char to an untagged representation. #!+sb-unicode (define-vop (move-to-character) (:args (x :scs (any-reg descriptor-reg) :target y - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:results (y :scs (character-reg) - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:note "character untagging") (:generator 1 - (move y x) - (inst shr y n-widetag-bits))) + (cond ((and (sc-is y character-reg) (sc-is x any-reg descriptor-reg)) + (let ((y-dword (make-dword-tn y))) + (unless (location= x y) + (inst mov y-dword (make-dword-tn x))) + (inst shr y-dword n-widetag-bits))) + (t + (move y x) + (inst shr y n-widetag-bits))))) #!-sb-unicode (define-vop (move-to-character) (:args (x :scs (any-reg control-stack))) @@ -31,25 +42,28 @@ (:note "character untagging") (:generator 1 (let ((y-wide-tn (make-random-tn - :kind :normal - :sc (sc-or-lose 'any-reg) - :offset (tn-offset y)))) + :kind :normal + :sc (sc-or-lose 'any-reg) + :offset (tn-offset y)))) (move y-wide-tn x) (inst shr y-wide-tn 8) (inst and y-wide-tn #xff)))) (define-move-vop move-to-character :move - (any-reg #!-sb-unicode control-stack) + (any-reg #!-sb-unicode control-stack) (character-reg)) ;;; Move an untagged char to a tagged representation. #!+sb-unicode (define-vop (move-from-character) - (:args (x :scs (character-reg))) + (:args (x :scs (character-reg) :target y)) (:results (y :scs (any-reg descriptor-reg))) (:note "character tagging") (:generator 1 - (inst imul y x (ash 1 n-widetag-bits)) - (inst or y character-widetag))) + (let ((y-dword (make-dword-tn y))) + (unless (location= x y) + (inst mov y-dword (make-dword-tn x))) + (inst shl y-dword n-widetag-bits) + (inst or y-dword character-widetag)))) #!-sb-unicode (define-vop (move-from-character) (:args (x :scs (character-reg character-stack))) @@ -57,22 +71,22 @@ (:note "character tagging") (:generator 1 (move (make-random-tn :kind :normal :sc (sc-or-lose 'character-reg) - :offset (tn-offset y)) - x) + :offset (tn-offset y)) + x) (inst shl y n-widetag-bits) (inst or y character-widetag) (inst and y #xffff))) (define-move-vop move-from-character :move - (character-reg) + (character-reg) (any-reg descriptor-reg #!-sb-unicode control-stack)) ;;; Move untagged character values. (define-vop (character-move) (:args (x :target y - :scs (character-reg) - :load-if (not (location= x y)))) + :scs (character-reg) + :load-if (not (location= x y)))) (:results (y :scs (character-reg character-stack) - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:note "character move") (:effects) (:affected) @@ -84,9 +98,9 @@ ;;; Move untagged character arguments/return-values. (define-vop (move-character-arg) (:args (x :target y - :scs (character-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y character-reg)))) + :scs (character-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y character-reg)))) (:results (y)) (:note "character arg move") (:generator 0 @@ -96,14 +110,14 @@ (character-stack #!-sb-unicode (inst mov - ;; FIXME: naked 8 (should be... what? n-register-bytes? - ;; n-word-bytes? Dunno. - (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) 8))) - x) + ;; XXX: If the sb-unicode case needs to handle c-call, + ;; why does the non-unicode case not need to? + (make-ea :byte :base fp :disp (frame-byte-offset (tn-offset y))) + x) #!+sb-unicode (if (= (tn-offset fp) esp-offset) - (storew x fp (tn-offset y)) ; c-call - (storew x fp (- (1+ (tn-offset y))))))))) + (storew x fp (tn-offset y)) ; c-call + (storew x fp (frame-word-offset (tn-offset y)))))))) (define-move-vop move-character-arg :move-arg (any-reg character-reg) (character-reg)) @@ -117,7 +131,8 @@ (define-vop (char-code) (:translate char-code) (:policy :fast-safe) - (:args (ch :scs (character-reg character-stack))) + (:args #!-sb-unicode (ch :scs (character-reg character-stack)) + #!+sb-unicode (ch :scs (character-reg character-stack) :target res)) (:arg-types character) (:results (res :scs (unsigned-reg))) (:result-types positive-fixnum) @@ -125,18 +140,18 @@ #!-sb-unicode (inst movzx res ch) #!+sb-unicode - (inst mov res ch))) + (move res ch))) #!+sb-unicode (define-vop (code-char) (:translate code-char) (:policy :fast-safe) - (:args (code :scs (unsigned-reg unsigned-stack))) + (:args (code :scs (unsigned-reg unsigned-stack) :target res)) (:arg-types positive-fixnum) (:results (res :scs (character-reg))) (:result-types character) (:generator 1 - (inst mov res code))) + (move res code))) #!-sb-unicode (define-vop (code-char) (:translate code-char) @@ -144,8 +159,8 @@ (:args (code :scs (unsigned-reg unsigned-stack) :target eax)) (:arg-types positive-fixnum) (:temporary (:sc unsigned-reg :offset rax-offset :target res - :from (:argument 0) :to (:result 0)) - eax) + :from (:argument 0) :to (:result 0)) + eax) (:results (res :scs (character-reg))) (:result-types character) (:generator 1 @@ -155,51 +170,45 @@ ;;; comparison of CHARACTERs (define-vop (character-compare) (:args (x :scs (character-reg character-stack)) - (y :scs (character-reg) - :load-if (not (and (sc-is x character-reg) - (sc-is y character-stack))))) + (y :scs (character-reg) + :load-if (not (and (sc-is x character-reg) + (sc-is y character-stack))))) (:arg-types character character) - (:conditional) - (:info target not-p) + (:info) (:policy :fast-safe) (:note "inline comparison") - (:variant-vars condition not-condition) (:generator 3 - (inst cmp x y) - (inst jmp (if not-p not-condition condition) target))) + (inst cmp x y))) (define-vop (fast-char=/character character-compare) (:translate char=) - (:variant :e :ne)) + (:conditional :e)) (define-vop (fast-char/character character-compare) (:translate char>) - (:variant :a :na)) + (:conditional :a)) (define-vop (character-compare/c) (:args (x :scs (character-reg character-stack))) (:arg-types character (:constant character)) - (:conditional) - (:info target not-p y) + (:info y) (:policy :fast-safe) (:note "inline constant comparison") - (:variant-vars condition not-condition) (:generator 2 - (inst cmp x (sb!xc:char-code y)) - (inst jmp (if not-p not-condition condition) target))) + (inst cmp x (sb!xc:char-code y)))) (define-vop (fast-char=/character/c character-compare/c) (:translate char=) - (:variant :e :ne)) + (:conditional :e)) (define-vop (fast-char/character/c character-compare/c) (:translate char>) - (:variant :a :na)) + (:conditional :a))