Index: /trunk/ccl/compiler/X86/X8664/x8664-vinsns.lisp =================================================================== --- /trunk/ccl/compiler/X86/X8664/x8664-vinsns.lisp (revision 5145) +++ /trunk/ccl/compiler/X86/X8664/x8664-vinsns.lisp (revision 5146) @@ -663,5 +663,5 @@ -(define-x8664-vinsn u8->char (((dest :lisp) +(define-x8664-vinsn u32->char (((dest :lisp) (src :u8)) ((src :u8)) @@ -2564,4 +2564,19 @@ (jmp :again) :ok) + +(define-x8664-vinsn require-char-code (() + ((object :lisp)) + ((tag :u32))) + :again + (testb (:$b x8664::fixnummask) (:%b object)) + (jne.pn :bad) + (cmpq (:$l #x110000) (:%q object)) + (jb.pt :ok) + :bad + (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-mod-char-code-limit)) + (jmp :again) + :ok) + + @@ -2933,5 +2948,5 @@ (:%l dest))) -(define-x8664-vinsn %scharcode (((code :imm)) +(define-x8664-vinsn %scharcode8 (((code :imm)) ((str :lisp) (idx :imm)) @@ -2940,5 +2955,14 @@ (sarq (:$ub x8664::fixnumshift) (:%q imm)) (movzbl (:@ x8664::misc-data-offset (:%q str) (:%q imm)) (:%l imm)) - (leaq (:@ (:%q imm) 8) (:%q code))) + (imulq (:$b x8664::fixnumone) (:%q imm)(:%q code))) + +(define-x8664-vinsn %scharcode32 (((code :imm)) + ((str :lisp) + (idx :imm)) + ((imm :u64))) + (movq (:%q idx) (:%q imm)) + (sarq (:$ub 1) (:%q imm)) + (movl (:@ x8664::misc-data-offset (:%q str) (:%q imm)) (:%l imm)) + (imulq (:$b x8664::fixnumone) (:%q imm)(:%q code))) (define-x8664-subprim-jump-vinsn (tail-call-sym-slide) .SPtcallsymslide) @@ -3286,5 +3310,5 @@ -(define-x8664-vinsn %set-scharcode (() +(define-x8664-vinsn %set-scharcode8 (() ((str :lisp) (idx :imm) @@ -3297,4 +3321,17 @@ (shrq (:$ub x8664::word-shift) (:%q imm)) (movb (:%b imm1) (:@ x8664::misc-data-offset (:%q str) (:%q imm)))) + + +(define-x8664-vinsn %set-scharcode32 (() + ((str :lisp) + (idx :imm) + (code :imm)) + ((imm :u64) + (imm1 :u64))) + (movq (:%q code) (:%q imm1)) + (movq (:%q idx) (:%q imm)) + (shrq (:$ub x8664::fixnumshift) (:%q imm1)) + (shrq (:$ub 1) (:%q imm)) + (movl (:%l imm1) (:@ x8664::misc-data-offset (:%q str) (:%q imm)))) @@ -3639,5 +3676,5 @@ (testb (:%b x8664::arg_z) (:%b x8664::arg_z))) -(define-x8664-vinsn %schar (((char :imm)) +(define-x8664-vinsn %schar8 (((char :imm)) ((str :lisp) (idx :imm)) @@ -3649,11 +3686,21 @@ (leaq (:@ x8664::subtag-character (:%q imm)) (:%q char))) - -(define-x8664-vinsn %set-schar (() - ((str :lisp) - (idx :imm) - (char :imm)) - ((imm0 :u64) - (imm1 :u64))) +(define-x8664-vinsn %schar32 (((char :imm)) + ((str :lisp) + (idx :imm)) + ((imm :u32))) + (movq (:%q idx) (:%q imm)) + (shrq (:$ub 1) (:%q imm)) + (movl (:@ x8664::misc-data-offset (:%q str) (:%q imm)) (:%l imm)) + (shll (:$ub x8664::charcode-shift) (:%l imm)) + (leaq (:@ x8664::subtag-character (:%q imm)) (:%q char))) + + +(define-x8664-vinsn %set-schar8 (() + ((str :lisp) + (idx :imm) + (char :imm)) + ((imm0 :u64) + (imm1 :u64))) (movq (:%q idx) (:%q imm0)) (movl (:%l char) (:%l imm1)) @@ -3662,4 +3709,15 @@ (movb (:%b imm1) (:@ x8664::misc-data-offset (:%q str) (:%q imm0)))) +(define-x8664-vinsn %set-schar32 (() + ((str :lisp) + (idx :imm) + (char :imm)) + ((imm0 :u64) + (imm1 :u64))) + (movq (:%q idx) (:%q imm0)) + (movl (:%l char) (:%l imm1)) + (shrq (:$ub 1) (:%q imm0)) + (shrl (:$ub x8664::charcode-shift) (:%l imm1)) + (movl (:%l imm1) (:@ x8664::misc-data-offset (:%q str) (:%q imm0)))) (define-x8664-vinsn misc-set-c-single-float (((val :single-float)) Index: /trunk/ccl/compiler/X86/x862.lisp =================================================================== --- /trunk/ccl/compiler/X86/x862.lisp (revision 5145) +++ /trunk/ccl/compiler/X86/x862.lisp (revision 5146) @@ -1503,5 +1503,7 @@ (! misc-ref-c-u32 temp src index-known-fixnum)) (ensuring-node-target (target vreg) - (! box-fixnum target temp))))) + (if (eq type-keyword :simple-string) + (! u32->char target temp) + (! box-fixnum target temp)))))) (with-imm-temps () (idx-reg) @@ -1520,5 +1522,7 @@ (! misc-ref-u32 temp src idx-reg)) (ensuring-node-target (target vreg) - (! box-fixnum target temp))))))) + (if (eq type-keyword :simple-string) + (! u32->char target temp) + (! box-fixnum target temp)))))))) (if is-8-bit (with-imm-temps @@ -1538,5 +1542,5 @@ (if (eq type-keyword :simple-string) (ensuring-node-target (target vreg) - (! u8->char target temp)) + (! u32->char target temp)) (if (and (= vreg-mode hard-reg-class-gpr-mode-u8) (eq type-keyword :unsigned-8-bit-vector)) @@ -1976,5 +1980,7 @@ (if (typep constval 'single-float) (x862-single-float-bits constval) - constval)) + (if (typep constval 'character) + (char-code constval) + constval))) (cond ((eq type-keyword :single-float-vector) (when safe @@ -1983,4 +1989,6 @@ ((eq type-keyword :signed-32-bit-vector) (! unbox-s32 temp val-reg)) + ((eq type-keyword :simple-string) + (! unbox-base-char temp val-reg)) (t (! unbox-u32 temp val-reg)))) @@ -5828,5 +5836,5 @@ (ensuring-node-target (target vreg) (with-imm-target () (dest :u8) - (! u8->char target (let* ((*x862-reckless* t)) + (! u32->char target (let* ((*x862-reckless* t)) (x862-one-untargeted-reg-form seg c dest))))) (^)))) @@ -5834,17 +5842,21 @@ (defx862 x862-%schar %schar (seg vreg xfer str idx) (multiple-value-bind (src unscaled-idx) - (x862-two-untargeted-reg-forms seg str x8664::arg_y idx x8664::arg_z) + (x862-two-untargeted-reg-forms seg str x8664::arg_y idx x8664::arg_z) (if vreg (ensuring-node-target (target vreg) - (! %schar target src unscaled-idx))) + (case (arch::target-char-code-limit (backend-target-arch *target-backend*)) + (256 (! %schar8 target src unscaled-idx)) + (t (! %schar32 target src unscaled-idx))))) (^))) (defx862 x862-%set-schar %set-schar (seg vreg xfer str idx char) (multiple-value-bind (src unscaled-idx char) - (x862-three-untargeted-reg-forms seg - str x8664::arg_x - idx x8664::arg_y - char x8664::arg_z) - (! %set-schar src unscaled-idx char) + (x862-three-untargeted-reg-forms seg + str x8664::arg_x + idx x8664::arg_y + char x8664::arg_z) + (case (arch::target-char-code-limit (backend-target-arch *target-backend*)) + (256 (! %set-schar8 src unscaled-idx char)) + (t (! %set-schar32 src unscaled-idx char))) (when vreg (<- char)) (^))) @@ -5852,7 +5864,9 @@ (defx862 x862-%set-scharcode %set-scharcode (seg vreg xfer str idx char) (multiple-value-bind (src unscaled-idx char) - (x862-three-untargeted-reg-forms seg str x8664::arg_x idx x8664::arg_y - char x8664::arg_z) - (! %set-scharcode src unscaled-idx char) + (x862-three-untargeted-reg-forms seg str x8664::arg_x idx x8664::arg_y + char x8664::arg_z) + (case (arch::target-char-code-limit (backend-target-arch *target-backend*)) + (256 (! %set-scharcode8 src unscaled-idx char)) + (t (! %set-scharcode32 src unscaled-idx char))) (when vreg (<- char)) (^))) @@ -5860,8 +5874,10 @@ (defx862 x862-%scharcode %scharcode (seg vreg xfer str idx) (multiple-value-bind (src unscaled-idx) - (x862-two-untargeted-reg-forms seg str x8664::arg_y idx x8664::arg_z) + (x862-two-untargeted-reg-forms seg str x8664::arg_y idx x8664::arg_z) (if vreg (ensuring-node-target (target vreg) - (! %scharcode target src unscaled-idx))) + (case (arch::target-char-code-limit (backend-target-arch *target-backend*)) + (256 (! %scharcode8 target src unscaled-idx)) + (t (! %scharcode32 target src unscaled-idx))))) (^))) @@ -5870,5 +5886,8 @@ (defx862 x862-code-char code-char (seg vreg xfer c) (let* ((reg (x862-one-untargeted-reg-form seg c x8664::arg_z))) - (! require-u8 reg) ; Typecheck even if result unused. + ;; Typecheck even if result unused. + (case (arch::target-char-code-limit (backend-target-arch *target-backend*)) + (256 (! require-u8 reg)) + (t (! require-char-code reg))) (if vreg (ensuring-node-target (target vreg)