Index: /branches/ia32/compiler/X86/x862.lisp
===================================================================
--- /branches/ia32/compiler/X86/x862.lisp	(revision 7818)
+++ /branches/ia32/compiler/X86/x862.lisp	(revision 7819)
@@ -107,7 +107,9 @@
                              (:fpr hard-reg-class-fpr)
                              (:crf hard-reg-class-crf)))
-                          (mode-val
+                          (mode-val-or-form
                            (if (eq class :gpr)
-                             (gpr-mode-name-value mode)
+			     (if (member mode '(:natural :signed-natural))
+			       `(gpr-mode-name-value ,mode)
+			       (gpr-mode-name-value mode))
                              (if (eq class :fpr)
                                (if (eq mode :single-float)
@@ -117,5 +119,5 @@
                      `(make-unwired-lreg nil
                        :class ,class-val
-                       :mode ,mode-val)))
+                       :mode ,mode-val-or-form)))
                   ($ (reg &key (class :gpr) (mode :lisp))
                    (let* ((class-val
@@ -124,7 +126,9 @@
                              (:fpr hard-reg-class-fpr)
                              (:crf hard-reg-class-crf)))
-                          (mode-val
+                          (mode-val-or-form
                            (if (eq class :gpr)
-                             (gpr-mode-name-value mode)
+			     (if (member mode '(:natural :signed-natural))
+			       `(gpr-mode-name-value ,mode)
+			       (gpr-mode-name-value mode))
                              (if (eq class :fpr)
                                (if (eq mode :single-float)
@@ -134,5 +138,5 @@
                      `(make-wired-lreg ,reg
                        :class ,class-val
-                       :mode ,mode-val))))
+                       :mode ,mode-val-or-form))))
          ,@body))))
 
@@ -1475,14 +1479,32 @@
               (let* ((lab (x86-double-float-constant-label form)))
                 (! load-double-float-constant vreg lab))))
-          (if (and (typep form '(unsigned-byte 32))
-                   (= (hard-regspec-class vreg) hard-reg-class-gpr)
-                   (= (get-regspec-mode vreg)
-                      hard-reg-class-gpr-mode-u32))
-            (x862-lri seg vreg form)
-            (ensuring-node-target
-                (target vreg)
-              (if (characterp form)
-                (! load-character-constant target (char-code form))
-                (x862-store-immediate seg form target)))))
+	  (target-arch-case
+	   (:x8632
+	    (if (and (= (hard-regspec-class vreg) hard-reg-class-gpr)
+		     (member (get-regspec-mode vreg)
+			     '(hard-reg-class-gpr-mode-u32
+			       hard-reg-class-gpr-mode-s32
+			       hard-reg-class-gpr-mode-address))
+		     (or (typep form '(unsigned-byte 32))
+			 (typep form '(signed-byte 32))))
+	      ;; The bits fit.  Get them in the register somehow.
+	      (if (typep form '(signed-byte 32))
+		(x862-lri seg vreg form)
+		(x862-lriu seg vreg form))
+	      (ensuring-node-target (target vreg)
+		(if (characterp form)
+		  (! load-character-constant target (char-code form))
+		  (x862-store-immediate seg form target)))))
+	   (:x8664
+	    (if (and (typep form '(unsigned-byte 32))
+		     (= (hard-regspec-class vreg) hard-reg-class-gpr)
+		     (= (get-regspec-mode vreg)
+			hard-reg-class-gpr-mode-u32))
+	      (x862-lri seg vreg form)
+	      (ensuring-node-target
+		  (target vreg)
+		(if (characterp form)
+		  (! load-character-constant target (char-code form))
+		  (x862-store-immediate seg form target)))))))
         (if (and (listp form) *load-time-eval-token* (eq (car form) *load-time-eval-token*))
           (x862-store-immediate seg form ($ *x862-temp0*))))
@@ -1596,4 +1618,10 @@
         (! call-subprim (subprim-name->offset '.SPmakeu64))
         (x862-copy-register seg node-dest arg_z)))))
+
+(defun x862-single->heap (seg dest src)
+  (with-x86-local-vinsn-macros (seg)
+    (! setup-single-float-allocation)
+    (! %allocate-uvector dest)
+    (! set-single-float-value dest src)))
 
 (defun x862-double->heap (seg dest src)
@@ -1644,34 +1672,37 @@
                           (! single->node target fp-val)))))
                    (t
-                    (with-imm-target () temp
-                      (if is-signed
-                        (! misc-ref-c-s32 temp src index-known-fixnum)
-                        (! misc-ref-c-u32 temp src index-known-fixnum))
-                      (ensuring-node-target (target vreg)
-                        (if (eq type-keyword :simple-string)
-                          (! u32->char target temp)
-                          (! box-fixnum target temp))))))
-             (with-imm-target () idx-reg
-               (if index-known-fixnum
-                 (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
-                 (! scale-32bit-misc-index idx-reg unscaled-idx))
-               (cond ((eq type-keyword :single-float-vector)
-                      (with-fp-target () (fp-val :single-float)
-                        (if (and (eql vreg-class hard-reg-class-fpr)
-                                 (eql vreg-mode hard-reg-class-fpr-mode-single))
-                          (setq fp-val vreg))
-                        (! misc-ref-single-float fp-val src idx-reg)
-                        (if (eq vreg-class hard-reg-class-fpr)
-                          (<- fp-val)
-                          (ensuring-node-target (target vreg)
-                            (! single->node target fp-val)))))
-                     (t (with-imm-target () temp
-                          (if is-signed
-                            (! misc-ref-s32 temp src idx-reg)
-                            (! misc-ref-u32 temp src idx-reg))
-                          (ensuring-node-target (target vreg)
-                            (if (eq type-keyword :simple-string)
-                              (! u32->char target temp)
-                              (! box-fixnum target temp)))))))))
+		    (with-additional-imm-reg ()
+		      (with-imm-target () temp
+			(if is-signed
+			  (! misc-ref-c-s32 temp src index-known-fixnum)
+			  (! misc-ref-c-u32 temp src index-known-fixnum))
+			(ensuring-node-target (target vreg)
+			  (if (eq type-keyword :simple-string)
+			    (! u32->char target temp)
+			    (! box-fixnum target temp)))))))
+	     (with-additional-imm-reg ()
+	       (with-imm-target () idx-reg
+		 (if index-known-fixnum
+		   (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
+		   (! scale-32bit-misc-index idx-reg unscaled-idx))
+		 (cond ((eq type-keyword :single-float-vector)
+			(with-fp-target () (fp-val :single-float)
+			  (if (and (eql vreg-class hard-reg-class-fpr)
+				   (eql vreg-mode hard-reg-class-fpr-mode-single))
+			    (setq fp-val vreg))
+			  (! misc-ref-single-float fp-val src idx-reg)
+			  (if (eq vreg-class hard-reg-class-fpr)
+			    (<- fp-val)
+			    (ensuring-node-target (target vreg)
+			      (! single->node target fp-val)))))
+		       (t (with-additional-imm-reg ()
+			    (with-imm-target () temp
+			      (if is-signed
+				(! misc-ref-s32 temp src idx-reg)
+				(! misc-ref-u32 temp src idx-reg))
+			      (ensuring-node-target (target vreg)
+				(if (eq type-keyword :simple-string)
+				  (! u32->char target temp)
+				  (! box-fixnum target temp)))))))))))
           (is-8-bit
            (with-imm-target () temp
@@ -1680,11 +1711,12 @@
                  (! misc-ref-c-s8 temp src index-known-fixnum)
                  (! misc-ref-c-u8 temp src index-known-fixnum))
-               (with-imm-target () idx-reg
-                 (if index-known-fixnum
-                   (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) index-known-fixnum))
-                   (! scale-8bit-misc-index idx-reg unscaled-idx))
-                 (if is-signed
-                   (! misc-ref-s8 temp src idx-reg)
-                   (! misc-ref-u8 temp src idx-reg))))
+	       (with-additional-imm-reg ()
+		 (with-imm-target () idx-reg
+		   (if index-known-fixnum
+		     (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) index-known-fixnum))
+		     (! scale-8bit-misc-index idx-reg unscaled-idx))
+		   (if is-signed
+		     (! misc-ref-s8 temp src idx-reg)
+		     (! misc-ref-u8 temp src idx-reg)))))
              (if (eq type-keyword :simple-string)
                (ensuring-node-target (target vreg)
@@ -1703,11 +1735,12 @@
                    (! misc-ref-c-s16 temp src index-known-fixnum)
                    (! misc-ref-c-u16 temp src index-known-fixnum))
-                 (with-imm-target () idx-reg
-                   (if index-known-fixnum
-                     (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1)))
-                     (! scale-16bit-misc-index idx-reg unscaled-idx))
-                   (if is-signed
-                     (! misc-ref-s16 temp src idx-reg)
-                     (! misc-ref-u16 temp src idx-reg))))
+		 (with-additional-imm-reg ()
+		   (with-imm-target () idx-reg
+		     (if index-known-fixnum
+		       (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1)))
+		       (! scale-16bit-misc-index idx-reg unscaled-idx))
+		     (if is-signed
+		       (! misc-ref-s16 temp src idx-reg)
+		       (! misc-ref-u16 temp src idx-reg)))))
                (! box-fixnum target temp))))
           ;; Down to the dregs.
@@ -1762,12 +1795,13 @@
              (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch)))
                (! misc-ref-c-bit-fixnum target src index-known-fixnum)
-               (with-imm-temps
-                   () (word-index bitnum)
-                 (if index-known-fixnum
-                   (progn
-                     (x862-lri seg word-index (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum -6)))
-                     (x862-lri seg bitnum (logand index-known-fixnum #x63)))
-                   (! word-index-and-bitnum-from-index word-index bitnum unscaled-idx))
-                 (! ref-bit-vector-fixnum target bitnum src word-index))))))))
+	       (with-additional-imm-reg ()
+		 (with-imm-temps
+		     () (word-index bitnum)
+		   (if index-known-fixnum
+		     (progn
+		       (x862-lri seg word-index (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum -6)))
+		       (x862-lri seg bitnum (logand index-known-fixnum #x63)))
+		     (! word-index-and-bitnum-from-index word-index bitnum unscaled-idx))
+		   (! ref-bit-vector-fixnum target bitnum src word-index)))))))))
     (^)))
 
@@ -3385,4 +3419,8 @@
     (! lri reg value)))
 
+;;; unsigned variant
+(defun x862-lriu (seg reg value)
+  (with-x86-local-vinsn-macros (seg)
+    (! lriu reg value)))
 
 (defun x862-multiple-value-body (seg form)
@@ -4023,5 +4061,9 @@
                         (x862-double->heap seg dest src))
                        (#.hard-reg-class-fpr-mode-single
-                        (! single->node dest src)))))
+			(target-arch-case
+			 (:x8632
+			  (x862-single->heap seg dest src))
+			 (:x8664
+			  (! single->node dest src)))))))
                   (if (and src-fpr dest-fpr)
                     (unless (eql dest-fpr src-fpr)
@@ -6443,9 +6485,14 @@
 (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 *x862-arg-y*
+      (x862-three-untargeted-reg-forms seg str (target-arch-case
+						(:x8632 x8632::temp0)
+						(:x8664 x8664::arg_x))
+				       idx *x862-arg-y*
                                        char *x862-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)))
+      (t 
+       (with-additional-imm-reg ()
+	 (! %set-scharcode32 src unscaled-idx char))))
     (when vreg (<- char)) 
     (^)))
@@ -7598,12 +7645,13 @@
                    (! mem-ref-c-single-float fp-reg ptrreg fixoffset)))
                (with-imm-target () (ptrreg :address)
-                 (with-imm-target (ptrreg) (offsetreg :s64)
-                   (x862-two-targeted-reg-forms seg
-                                                ptr ptrreg
-                                                offset ($ *x862-arg-z*))
-                   (! fixnum->signed-natural offsetreg *x862-arg-z*)
-                   (if double-p
-                     (! mem-ref-double-float fp-reg ptrreg offsetreg)
-                     (! mem-ref-single-float fp-reg ptrreg offsetreg)))))
+		 (with-additional-imm-reg ()
+		   (with-imm-target (ptrreg) (offsetreg :signed-natural)
+		     (x862-two-targeted-reg-forms seg
+						  ptr ptrreg
+						  offset ($ *x862-arg-z*))
+		     (! fixnum->signed-natural offsetreg *x862-arg-z*)
+		     (if double-p
+		       (! mem-ref-double-float fp-reg ptrreg offsetreg)
+		       (! mem-ref-single-float fp-reg ptrreg offsetreg))))))
              (<- fp-reg))
            (^)))))
@@ -7637,22 +7685,23 @@
                         (! mem-set-c-single-float fp-reg ptr-reg fixoffset)))
                      (t
-                      (with-imm-target (ptr-reg) (offset-reg :s32)
-                        (x862-push-register
-                         seg
-                         (x862-one-untargeted-reg-form seg
-                                                       ptr
-                                                       ptr-reg))
-                        (x862-push-register
-                         seg
-                         (x862-one-untargeted-reg-form seg
-                                                       offset
-                                                       *x862-arg-z*))
-                        (x862-one-targeted-reg-form seg newval fp-reg)
-                        (x862-pop-register seg *x862-arg-z*)
-                        (x862-pop-register seg ptr-reg)
-                        (! fixnum->signed-natural offset-reg *x862-arg-z*)
-                        (if double-p
-                          (! mem-set-double-float fp-reg ptr-reg offset-reg)
-                          (! mem-set-single-float fp-reg ptr-reg offset-reg)))))
+		      (with-additional-imm-reg ()
+			(with-imm-target (ptr-reg) (offset-reg :s32)
+			  (x862-push-register
+			   seg
+			   (x862-one-untargeted-reg-form seg
+							 ptr
+							 ptr-reg))
+			  (x862-push-register
+			   seg
+			   (x862-one-untargeted-reg-form seg
+							 offset
+							 *x862-arg-z*))
+			  (x862-one-targeted-reg-form seg newval fp-reg)
+			  (x862-pop-register seg *x862-arg-z*)
+			  (x862-pop-register seg ptr-reg)
+			  (! fixnum->signed-natural offset-reg *x862-arg-z*)
+			  (if double-p
+			    (! mem-set-double-float fp-reg ptr-reg offset-reg)
+			    (! mem-set-single-float fp-reg ptr-reg offset-reg))))))
                (<- fp-reg))
               (t
@@ -7666,9 +7715,10 @@
                         (x862-one-targeted-reg-form seg newval rnew)
                         (x862-pop-register seg ptr-reg)
-                        (with-imm-temps (ptr-reg) ()
-                          (x862-copy-register seg fp-reg rnew)
-                          (if double-p
-                            (! mem-set-c-double-float fp-reg ptr-reg fixoffset)
-                            (! mem-set-c-single-float fp-reg ptr-reg fixoffset)))))
+			(with-additional-imm-reg ()
+			  (with-imm-temps (ptr-reg) ()
+			    (x862-copy-register seg fp-reg rnew)
+			    (if double-p
+			      (! mem-set-c-double-float fp-reg ptr-reg fixoffset)
+			      (! mem-set-c-single-float fp-reg ptr-reg fixoffset))))))
                      (t
                       (let* ((roffset ($ *x862-arg-y*))
@@ -7683,11 +7733,13 @@
                                                    newval rnew)
                         (x862-pop-register seg ptr-reg)
-                        (with-imm-target (ptr-reg) (offset-reg :s32)
-                          (with-imm-temps (ptr-reg) ()
-                            (x862-copy-register seg fp-reg rnew)
-                            (! fixnum->signed-natural offset-reg roffset))
-                        (if double-p
-                          (! mem-set-double-float fp-reg ptr-reg offset-reg)
-                          (! mem-set-single-float fp-reg ptr-reg offset-reg))))))
+			(with-additional-imm-reg ()
+			  (with-imm-target (ptr-reg) (offset-reg :s32)
+			    (with-additional-imm-reg ()
+			      (with-imm-temps (ptr-reg) ()
+				(x862-copy-register seg fp-reg rnew)
+				(! fixnum->signed-natural offset-reg roffset)))
+			    (if double-p
+			      (! mem-set-double-float fp-reg ptr-reg offset-reg)
+			      (! mem-set-single-float fp-reg ptr-reg offset-reg)))))))
                (<- *x862-arg-z*)))
         (^)))))
@@ -7755,17 +7807,18 @@
             (x862-one-targeted-reg-form seg ptr src-reg)
           (if (node-reg-p vreg)
-            (! mem-ref-c-bit-fixnum vreg src-reg offval)
-            (with-imm-target ()           ;OK if src-reg & dest overlap
-                (dest :u8)
-              (! mem-ref-c-bit dest src-reg offval)
-              (<- dest))))
+	    (! mem-ref-c-bit-fixnum vreg src-reg offval)
+	    (with-imm-target ()           ;OK if src-reg & dest overlap
+		(dest :u8)
+	      (! mem-ref-c-bit dest src-reg offval)
+	      (<- dest))))
         (with-imm-target () (src-reg :address)
           (x862-two-targeted-reg-forms seg ptr src-reg offset ($ *x862-arg-z*))
           (if (node-reg-p vreg)
-            (! mem-ref-bit-fixnum vreg src-reg ($ *x862-arg-z*))
-            (with-imm-target ()           ;OK if src-reg & dest overlap
-                (dest :u8)
-              (! mem-ref-bit dest src-reg offset)
-              (<- dest)))))
+	    (with-additional-imm-reg (*x862-arg-z*)
+	      (! mem-ref-bit-fixnum vreg src-reg ($ *x862-arg-z*)))
+	    (with-imm-target ()           ;OK if src-reg & dest overlap
+		(dest :u8)
+	      (! mem-ref-bit dest src-reg offset)
+	      (<- dest)))))
       (^))))
 
@@ -8621,4 +8674,19 @@
     (^)))
 
+;; used for x8632 only
+(defx862 x862-%setf-short-float %setf-short-float (seg vref xfer fnode fval)
+  (target-arch-case
+   (:x8664 (error "%setf-short-float makes no sense on x8664")))
+  (x862-vpush-register seg (x862-one-untargeted-reg-form seg fnode *x862-arg-z*))
+  (let* ((target ($ *x862-fp1* :class :fpr :mode :single-float))
+         (node ($ *x862-arg-z*)))
+    (x862-one-targeted-reg-form seg fval target)
+    (x862-vpop-register seg node)
+    (unless (or *x862-reckless* (x862-form-typep fnode 'single-float))
+      (! trap-unless-single-float node))
+    (! store-single node target)
+    (<- node)
+    (^)))
+
 (defx862 x862-%setf-double-float %setf-double-float (seg vref xfer fnode fval)
   (x862-vpush-register seg (x862-one-untargeted-reg-form seg fnode *x862-arg-z*))
@@ -8697,8 +8765,9 @@
             (if (typep abs '(signed-byte 16))              
               (x862-test-reg-%izerop seg vreg xfer other-target cr-bit true-p abs)
-              (with-imm-temps (other-target) ((abs-target :address))
-                (use-imm-temp other-target)
-                (x862-lri seg abs-target abs)
-                (x862-compare-registers seg vreg xfer other-target abs-target cr-bit true-p))))
+	      (with-additional-imm-reg ()
+		(with-imm-temps (other-target) ((abs-target :address))
+		  (use-imm-temp other-target)
+		  (x862-lri seg abs-target abs)
+		  (x862-compare-registers seg vreg xfer other-target abs-target cr-bit true-p)))))
           ;; Neither expression is obviously a constant-valued macptr.
           (with-imm-target () (target-a :address)
@@ -8707,8 +8776,9 @@
             (x862-open-undo $undostkblk)
             (x862-one-targeted-reg-form seg y target-a)
-            (with-imm-target (target-a) (target-b :address)
-              (! temp-pop-unboxed-word target-b)
-              (x862-close-undo)
-              (x862-compare-registers seg vreg xfer target-b target-a cr-bit true-p))))))))
+	    (with-additional-imm-reg ()
+	      (with-imm-target (target-a) (target-b :address)
+		(! temp-pop-unboxed-word target-b)
+		(x862-close-undo)
+		(x862-compare-registers seg vreg xfer target-b target-a cr-bit true-p)))))))))
 
 (defx862 x862-set-bit %set-bit (seg vreg xfer ptr offset newval)
@@ -8727,5 +8797,6 @@
             (with-imm-target () (src :address)
               (x862-two-targeted-reg-forms seg ptr src newval ($ *x862-arg-z*))
-              (! mem-set-c-bit-variable-value src offval ($ *x862-arg-z*))
+	      (with-additional-imm-reg ()
+		(! mem-set-c-bit-variable-value src offval ($ *x862-arg-z*)))
               (<- ($ *x862-arg-z*)))))
         (if constval
@@ -8739,5 +8810,6 @@
           (with-imm-target () (src :address)
             (x862-three-targeted-reg-forms seg ptr src offset ($ *x862-arg-y*) newval ($ *x862-arg-z*))
-            (! mem-set-bit-variable-value src ($ *x862-arg-y*) ($ *x862-arg-z*))
+	    (with-additional-imm-reg ()
+	      (! mem-set-bit-variable-value src ($ *x862-arg-y*) ($ *x862-arg-z*)))
             (<- ($ *x862-arg-z*)))))
       (^)))
@@ -8875,4 +8947,5 @@
 (defx862 x862-i386-ff-call i386-ff-call (seg vreg xfer address argspecs argvals resultspec &optional monitor)
   (declare (ignore monitor))
+  #+debug
   (format t "~&~%i386-ff-call: argspecs = ~s, argvals = ~s, resultspec = ~s"
 	  argspecs argvals resultspec)