source: branches/working-0711/ccl/compiler/X86/x862.lisp @ 8019

;;;-*-Mode: LISP; Package: CCL -*-
;;;
;;;Â  Â Copyright (C) 2005, Clozure Associates
;;;   This file is part of OpenMCL.  
;;;
;;;Â  Â OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
;;;Â  Â License , known as the LLGPL and distributed with OpenMCL as the
;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
;;;   conflict, the preamble takes precedence.  
;;;
;;;Â  Â OpenMCL is referenced in the preamble as the "LIBRARY."
;;;
;;;Â  Â The LLGPL is also available online at
;;;Â  Â http://opensource.franz.com/preamble.html

(in-package "CCL")

(eval-when (:compile-toplevel :execute)
  (require "NXENV")
  (require "X8664ENV"))

(eval-when (:load-toplevel :execute :compile-toplevel)
  (require "X86-BACKEND"))

(defparameter *x862-debug-mask* 0)
(defconstant x862-debug-verbose-bit 0)
(defconstant x862-debug-vinsns-bit 1)
(defconstant x862-debug-lcells-bit 2)
(defparameter *x862-target-lcell-size* 0)
(defparameter *x862-target-node-size* 0)
(defparameter *x862-target-dnode-size* 0)
(defparameter *x862-target-fixnum-shift* 0)
(defparameter *x862-target-node-shift* 0)
(defparameter *x862-target-bits-in-word* 0)
(defparameter *x862-target-num-arg-regs* 0)
(defparameter *x862-target-num-save-regs* 0)
(defparameter *x862-target-half-fixnum-type* nil)

(defparameter *x862-operator-supports-u8-target* ())
(defparameter *x862-operator-supports-push* ())
(defparameter *x862-tos-reg* ())



  
(defun x862-immediate-operand (x)
  (if (eq (acode-operator x) (%nx1-operator immediate))
    (cadr x)
    (compiler-bug "not an immediate: ~s" x)))

(defmacro with-x86-p2-declarations (declsform &body body)
  `(let* ((*x862-tail-allow* *x862-tail-allow*)
          (*x862-reckless* *x862-reckless*)
          (*x862-open-code-inline* *x862-open-code-inline*)
          (*x862-trust-declarations* *x862-trust-declarations*))
     (x862-decls ,declsform)
     ,@body))


(defmacro with-x86-local-vinsn-macros ((segvar &optional vreg-var xfer-var) &body body)
  (declare (ignorable xfer-var))
  (let* ((template-name-var (gensym))
         (template-temp (gensym))
         (args-var (gensym))
         (labelnum-var (gensym))
         (retvreg-var (gensym))
         (label-var (gensym)))
    `(macrolet ((! (,template-name-var &rest ,args-var)                 
                  (let* ((,template-temp (get-vinsn-template-cell ,template-name-var (backend-p2-vinsn-templates *target-backend*))))
                    (unless ,template-temp
                      (warn "VINSN \"~A\" not defined" ,template-name-var))
                    `(prog1
                      (%emit-vinsn ,',segvar ',,template-name-var (backend-p2-vinsn-templates *target-backend*) ,@,args-var)
                      (setq *x862-tos-reg* nil)))))
       (macrolet ((<- (,retvreg-var)
                    `(x862-copy-register ,',segvar ,',vreg-var ,,retvreg-var))
                  (@  (,labelnum-var)
                    `(backend-gen-label ,',segvar ,,labelnum-var))
                  (@= (,labelnum-var)
                    `(x862-emit-aligned-label ,',segvar ,,labelnum-var))
                  (-> (,label-var)
                    `(! jump (aref *backend-labels* ,,label-var)))
                  (^ (&rest branch-args)
                    `(x862-branch ,',segvar ,',xfer-var ,@branch-args))
                  (? (&key (class :gpr)
                          (mode :lisp))
                   (let* ((class-val
                           (ecase class
                             (:gpr hard-reg-class-gpr)
                             (:fpr hard-reg-class-fpr)
                             (:crf hard-reg-class-crf)))
                          (mode-val
                           (if (eq class :gpr)
                             (gpr-mode-name-value mode)
                             (if (eq class :fpr)
                               (if (eq mode :single-float)
                                 hard-reg-class-fpr-mode-single
                                 hard-reg-class-fpr-mode-double)
                               0))))
                     `(make-unwired-lreg nil
                       :class ,class-val
                       :mode ,mode-val)))
                  ($ (reg &key (class :gpr) (mode :lisp))
                   (let* ((class-val
                           (ecase class
                             (:gpr hard-reg-class-gpr)
                             (:fpr hard-reg-class-fpr)
                             (:crf hard-reg-class-crf)))
                          (mode-val
                           (if (eq class :gpr)
                             (gpr-mode-name-value mode)
                             (if (eq class :fpr)
                               (if (eq mode :single-float)
                                 hard-reg-class-fpr-mode-single
                                 hard-reg-class-fpr-mode-double)
                               0))))
                     `(make-wired-lreg ,reg
                       :class ,class-val
                       :mode ,mode-val))))
         ,@body))))



(defvar *x86-current-context-annotation* nil)
(defvar *x862-woi* nil)
(defvar *x862-open-code-inline* nil)
(defvar *x862-register-restore-count* 0)
(defvar *x862-register-restore-ea* nil)
(defvar *x862-compiler-register-save-label* nil)
(defvar *x862-valid-register-annotations* 0)
(defvar *x862-register-annotation-types* nil)
(defvar *x862-register-ea-annotations* nil)
(defvar *x862-constant-alist* nil)
(defvar *x862-double-float-constant-alist* nil)
(defvar *x862-single-float-constant-alist* nil)

(defparameter *x862-tail-call-aliases*
  ()
  #| '((%call-next-method . (%tail-call-next-method . 1))) |#
  
)

(defvar *x862-popreg-labels* nil)
(defvar *x862-popj-labels* nil)
(defvar *x862-valret-labels* nil)
(defvar *x862-nilret-labels* nil)

(defvar *x862-icode* nil)
(defvar *x862-undo-stack* nil)
(defvar *x862-undo-because* nil)


(defvar *x862-cur-afunc* nil)
(defvar *x862-vstack* 0)
(defvar *x862-cstack* 0)
(defvar *x862-undo-count* 0)
(defvar *x862-returning-values* nil)
(defvar *x862-vcells* nil)
(defvar *x862-fcells* nil)
(defvar *x862-entry-vsp-saved-p* nil)

(defvar *x862-entry-label* nil)
(defvar *x862-tail-label* nil)
(defvar *x862-tail-vsp* nil)
(defvar *x862-tail-nargs* nil)
(defvar *x862-tail-allow* t)
(defvar *x862-reckless* nil)
(defvar *x862-trust-declarations* nil)
(defvar *x862-entry-vstack* nil)
(defvar *x862-fixed-nargs* nil)
(defvar *x862-need-nargs* t)

(defparameter *x862-inhibit-register-allocation* nil)
(defvar *x862-record-symbols* nil)
(defvar *x862-recorded-symbols* nil)

(defvar *x862-result-reg* x8664::arg_z)


(declaim (fixnum *x862-vstack* *x862-cstack*))

 



(defvar *x862-all-lcells* ())

(defun x86-immediate-label (imm)
  (or (cdr (assoc imm *x862-constant-alist* :test #'eq))
      (let* ((lab (aref *backend-labels* (backend-get-next-label))))
        (push (cons imm lab) *x862-constant-alist*)
        lab)))

(defun x86-double-float-constant-label (imm)
  (or (cdr (assoc imm *x862-double-float-constant-alist*))
      (let* ((lab (aref *backend-labels* (backend-get-next-label))))
        (push (cons imm lab) *x862-double-float-constant-alist*)
        lab)))

(defun x86-single-float-constant-label (imm)
  (or (cdr (assoc imm *x862-single-float-constant-alist*))
      (let* ((lab (aref *backend-labels* (backend-get-next-label))))
        (push (cons imm lab) *x862-single-float-constant-alist*)
        lab)))


(defun x862-free-lcells ()
  (without-interrupts 
   (let* ((prev (pool.data *lcell-freelist*)))
     (dolist (r *x862-all-lcells*)
       (setf (lcell-kind r) prev
             prev r))
     (setf (pool.data *lcell-freelist*) prev)
     (setq *x862-all-lcells* nil))))

(defun x862-note-lcell (c)
  (push c *x862-all-lcells*)
  c)

(defvar *x862-top-vstack-lcell* ())
(defvar *x862-bottom-vstack-lcell* ())

(defun x862-new-lcell (kind parent width attributes info)
  (x862-note-lcell (make-lcell kind parent width attributes info)))

(defun x862-new-vstack-lcell (kind width attributes info)
  (setq *x862-top-vstack-lcell* (x862-new-lcell kind *x862-top-vstack-lcell* width attributes info)))

(defun x862-reserve-vstack-lcells (n)
  (dotimes (i n) (x862-new-vstack-lcell :reserved *x862-target-lcell-size* 0 nil)))

(defun x862-vstack-mark-top ()
  (x862-new-lcell :tos *x862-top-vstack-lcell* 0 0 nil))

;;; Alist mapping VARs to lcells/lregs
(defvar *x862-var-cells* ())

(defun x862-note-var-cell (var cell)
  ;(format t "~& ~s -> ~s" (var-name var) cell)
  (push (cons var cell) *x862-var-cells*))

(defun x862-note-top-cell (var)
  (x862-note-var-cell var *x862-top-vstack-lcell*))

(defun x862-lookup-var-cell (var)
  (or (cdr (assq var *x862-var-cells*))
      (and nil (warn "Cell not found for ~s" (var-name var)))))

(defun x862-collect-lcells (kind &optional (bottom *x862-bottom-vstack-lcell*) (top *x862-top-vstack-lcell*))
  (do* ((res ())
        (cell top (lcell-parent cell)))
       ((eq cell bottom) res)
    (if (null cell)
      (compiler-bug "Horrible compiler bug.")
      (if (eq (lcell-kind cell) kind)
        (push cell res)))))


  
;;; ensure that lcell's offset matches what we expect it to.
;;; For bootstrapping.

(defun x862-ensure-lcell-offset (c expected)
  (if c (= (calc-lcell-offset c) expected) (zerop expected)))

(defun x862-check-lcell-depth (&optional (context "wherever"))
  (when (logbitp x862-debug-verbose-bit *x862-debug-mask*)
    (let* ((depth (calc-lcell-depth *x862-top-vstack-lcell*)))
      (or (= depth *x862-vstack*)
          (warn "~a: lcell depth = ~d, vstack = ~d" context depth *x862-vstack*)))))

(defun x862-do-lexical-reference (seg vreg ea)
  (when vreg
    (with-x86-local-vinsn-macros (seg vreg)
      (if (eq vreg :push)
        (if (memory-spec-p ea)
          (if (addrspec-vcell-p ea)
            (with-node-target () target
              (x862-stack-to-register seg ea target)
              (! vcell-ref target target)
              (! vpush-register target))
            (! vframe-push (memspec-frame-address-offset ea) *x862-vstack*))
          (! vpush-register ea))
        (if (memory-spec-p ea)
          (ensuring-node-target (target vreg)
            (progn
              (x862-stack-to-register seg ea target)
              (if (addrspec-vcell-p ea)
                (! vcell-ref target target))))
          (<- ea))))))

(defun x862-do-lexical-setq (seg vreg ea valreg)
  (with-x86-local-vinsn-macros (seg vreg)
    (cond ((typep ea 'lreg)
            (x862-copy-register seg ea valreg))
          ((addrspec-vcell-p ea)     ; closed-over vcell
           (x862-copy-register seg x8664::arg_z valreg)
           (x862-stack-to-register seg ea x8664::arg_x)
           (x862-lri seg x8664::arg_y 0)
           (! call-subprim-3 x8664::arg_z (subprim-name->offset '.SPgvset) x8664::arg_x x8664::arg_y x8664::arg_z))
          ((memory-spec-p ea)    ; vstack slot
           (x862-register-to-stack seg valreg ea))
          (t
           (x862-copy-register seg ea valreg)))
    (when vreg
      (<- valreg))))

;;; ensure that next-method-var is heap-consed (if it's closed over.)
;;; it isn't ever setqed, is it ?
(defun x862-heap-cons-next-method-var (seg var)
  (with-x86-local-vinsn-macros (seg)
    (when (eq (ash 1 $vbitclosed)
              (logand (logior (ash 1 $vbitclosed)
                              (ash 1 $vbitcloseddownward))
                      (the fixnum (nx-var-bits var))))
      (let* ((ea (var-ea var))
             (arg ($ x8664::arg_z))
             (result ($ x8664::arg_z)))
        (x862-do-lexical-reference seg arg ea)
        (x862-set-nargs seg 1)
        (! ref-constant ($ x8664::fname) (x86-immediate-label (x862-symbol-entry-locative '%cons-magic-next-method-arg)))
        (! call-known-symbol arg)
        (x862-do-lexical-setq seg nil ea result)))))

;;; If we change the order of operands in a binary comparison operation,
;;; what should the operation change to ? (eg., (< X Y) means the same
;;; thing as (> Y X)).
(defparameter *x862-reversed-cr-bits*
  (vector
   nil                                  ;o ?
   nil                                  ;no ?
   x86::x86-a-bits                      ;b -> a
   x86::x86-be-bits                     ;ae -> be
   x86::x86-e-bits                      ;e->e
   x86::x86-ne-bits                     ;ne->ne
   x86::x86-ae-bits                     ;be->ae
   x86::x86-b-bits                      ;a->b
   nil                                  ;s ?
   nil                                  ;ns ?
   nil                                  ;pe ?
   nil                                  ;po ?
   x86::x86-g-bits                      ;l->g
   x86::x86-le-bits                     ;ge->le
   x86::x86-ge-bits                     ;le->ge
   x86::x86-l-bits                      ;g->l
   ))

(defun x862-reverse-cr-bit (cr-bit)
  (or (svref *x862-reversed-cr-bits* cr-bit)
      (compiler-bug "Can't reverse CR bit ~d" cr-bit)))


(defun acode-condition-to-x86-cr-bit (cond)
  (condition-to-x86-cr-bit (cadr cond)))

(defun condition-to-x86-cr-bit (cond)
  (case cond
    (:EQ (values x86::x86-e-bits t))
    (:NE (values x86::x86-e-bits nil))
    (:GT (values x86::x86-le-bits nil))
    (:LE (values x86::x86-le-bits t))
    (:LT (values x86::x86-l-bits t))
    (:GE (values x86::x86-l-bits nil))))

;;; Generate the start and end bits for a RLWINM instruction that
;;; would be equivalent to to LOGANDing the constant with some value.
;;; Return (VALUES NIL NIL) if the constant contains more than one
;;; sequence of consecutive 1-bits, else bit indices.
;;; The caller generally wants to treat the constant as an (UNSIGNED-BYTE 32);
;;; since this uses LOGCOUNT and INTEGER-LENGTH to find the significant
;;; bits, it ensures that the constant is a (SIGNED-BYTE 32) that has
;;; the same least-significant 32 bits.
(defun x862-mask-bits (constant)
  (if (< constant 0) (setq constant (logand #xffffffff constant)))
  (if (= constant #xffffffff)
    (values 0 31)
    (if (zerop constant)
      (values nil nil)
      (let* ((signed (if (and (logbitp 31 constant)
                              (> constant 0))
                       (- constant (ash 1 32))
                       constant))
             (count (logcount signed))
             (len (integer-length signed))
             (highbit (logbitp (the fixnum (1- len)) constant)))
        (declare (fixnum count len))
        (do* ((i 1 (1+ i))
              (pos (- len 2) (1- pos)))
             ((= i count)
              (let* ((start (- 32 len))
                     (end (+ count start)))
                (declare (fixnum start end))
                (if highbit
                  (values start (the fixnum (1- end)))
                  (values (logand 31 end)
                          (the fixnum (1- start))))))
          (declare (fixnum i pos))
          (unless (eq (logbitp pos constant) highbit)
            (return (values nil nil))))))))
    

(defun x862-ensure-binding-indices-for-vcells (vcells)
  (dolist (cell vcells)
    (ensure-binding-index (car cell)))
  vcells)

(defun x862-register-mask-byte (count)
  (if (> count 0)
    (logior
     (ash 1 (- x8664::save0 8))
     (if (> count 1)
       (logior
        (ash 1 (- x8664::save1 8))
        (if (> count 2)
          (logior
           (ash 1 (- x8664::save2 8))
           (if (> count 3)
             (ash 1 (- x8664::save3 8))
             0))
          0))
       0))
    0))

(defun x862-encode-register-save-ea (ea count)
  (if (zerop count)
    0 
    (min (- (ash ea (- x8664::word-shift)) count) #xff)))


(defun x862-compile (afunc &optional lambda-form *x862-record-symbols*)
  (progn
    (dolist (a  (afunc-inner-functions afunc))
      (unless (afunc-lfun a)
        (x862-compile a 
                      (if lambda-form 
                        (afunc-lambdaform a)) 
                      *x862-record-symbols*))) ; always compile inner guys
    (let* ((*x862-cur-afunc* afunc)
           (*x862-returning-values* nil)
           (*x86-current-context-annotation* nil)
           (*x862-woi* nil)
           (*next-lcell-id* -1)
           (*x862-open-code-inline* nil)
           (*x862-register-restore-count* nil)
           (*x862-compiler-register-save-label* nil)
           (*x862-valid-register-annotations* 0)
           (*x862-register-ea-annotations* (x862-make-stack 16))
           (*x862-register-restore-ea* nil)
           (*x862-constant-alist* nil)
           (*x862-double-float-constant-alist* nil)
           (*x862-single-float-constant-alist* nil)
           (*x862-vstack* 0)
           (*x862-cstack* 0)
           (*x862-target-num-arg-regs* (target-arch-case (:x8664  $numx8664argregs)))
           (*x862-target-num-save-regs* (target-arch-case (:x8664  $numx8664saveregs)))
           (*x862-target-lcell-size* (arch::target-lisp-node-size (backend-target-arch *target-backend*)))
           (*x862-target-fixnum-shift* (arch::target-fixnum-shift (backend-target-arch *target-backend*)))
           (*x862-target-node-shift* (arch::target-word-shift  (backend-target-arch *target-backend*)))
           (*x862-target-bits-in-word* (arch::target-nbits-in-word (backend-target-arch *target-backend*)))
           (*x862-target-node-size* *x862-target-lcell-size*)
           (*x862-target-half-fixnum-type* `(signed-byte ,(- *x862-target-bits-in-word*
                                                            (1+ *x862-target-fixnum-shift*))))
           (*x862-target-dnode-size* (* 2 *x862-target-lcell-size*))
           (*x862-tos-reg* nil)
           (*x862-all-lcells* ())
           (*x862-top-vstack-lcell* nil)
           (*x862-bottom-vstack-lcell* (x862-new-vstack-lcell :bottom 0 0 nil))
           (*x862-var-cells* nil)
           (*backend-vinsns* (backend-p2-vinsn-templates *target-backend*))
           (*backend-node-regs* (target-arch-case (:x8664 x8664-node-regs)))
           (*backend-node-temps* (target-arch-case (:x8664 x8664-temp-node-regs)))
           (*available-backend-node-temps* (target-arch-case (:x8664 x8664-temp-node-regs)))
           (*backend-imm-temps* (target-arch-case (:x8664 x8664-imm-regs)))
           (*available-backend-imm-temps* (target-arch-case (:x8664 x8664-imm-regs)))
           (*backend-crf-temps* (target-arch-case (:x8664 x8664-cr-fields)))
           (*available-backend-crf-temps* (target-arch-case (:x8664 x8664-cr-fields)))
           (*backend-fp-temps* (target-arch-case (:x8664 x8664-temp-fp-regs)))
           (*available-backend-fp-temps* (target-arch-case (:x8664 x8664-temp-fp-regs)))
           (bits 0)
           (*logical-register-counter* -1)
           (*backend-all-lregs* ())
           (*x862-popj-labels* nil)
           (*x862-popreg-labels* nil)
           (*x862-valret-labels* nil)
           (*x862-nilret-labels* nil)
           (*x862-undo-count* 0)
           (*backend-labels* (x862-make-stack 64 target::subtag-simple-vector))
           (*x862-undo-stack* (x862-make-stack 64  target::subtag-simple-vector))
           (*x862-undo-because* (x862-make-stack 64))
           (*x862-entry-label* nil)
           (*x862-tail-label* nil)
           (*x862-tail-vsp* nil)
           (*x862-tail-nargs* nil)
           (*x862-inhibit-register-allocation* nil)
           (*x862-tail-allow* t)
           (*x862-reckless* nil)
           (*x862-trust-declarations* t)
           (*x862-entry-vstack* nil)
           (*x862-fixed-nargs* nil)
           (*x862-need-nargs* t)
           (fname (afunc-name afunc))
           (*x862-entry-vsp-saved-p* nil)
           (*x862-vcells* (x862-ensure-binding-indices-for-vcells (afunc-vcells afunc)))
           (*x862-fcells* (afunc-fcells afunc))
           *x862-recorded-symbols*)
      (set-fill-pointer
       *backend-labels*
       (set-fill-pointer
        *x862-undo-stack*
        (set-fill-pointer 
         *x862-undo-because*
         0)))
      (backend-get-next-label)          ; start @ label 1, 0 is confused with NIL in compound cd
      (with-dll-node-freelist (vinsns *vinsn-freelist*)
        (unwind-protect
             (progn
               (setq bits (x862-form vinsns (make-wired-lreg *x862-result-reg*) $backend-return (afunc-acode afunc)))
               (do* ((constants *x862-constant-alist* (cdr constants)))
                    ((null constants))
                 (let* ((imm (caar constants)))
                   (when (x862-symbol-locative-p imm)
                     (setf (caar constants) (car imm)))))
               (optimize-vinsns vinsns)
               (when (logbitp x862-debug-vinsns-bit *x862-debug-mask*)
                 (format t "~% vinsns for ~s (after generation)" (afunc-name afunc))
                 (do-dll-nodes (v vinsns) (format t "~&~s" v))
                 (format t "~%~%"))
            
               (with-dll-node-freelist ((frag-list make-frag-list) *frag-freelist*)
                 (with-dll-node-freelist ((uuo-frag-list make-frag-list) *frag-freelist*)
                 (let* ((*x86-lap-labels* nil)
                        (instruction (x86::make-x86-instruction))
                        (end-code-tag (gensym))
                        debug-info)
                   (make-x86-lap-label end-code-tag)
                   (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8)
                                                             *x86-lap-entry-offset*) -3))
                   (x86-lap-directive frag-list :byte 0) ;regsave PC 
                   (x86-lap-directive frag-list :byte 0) ;regsave ea
                   (x86-lap-directive frag-list :byte 0) ;regsave mask

                   (x862-expand-vinsns vinsns frag-list instruction uuo-frag-list)
                   (when (or *x862-double-float-constant-alist*
                             *x862-single-float-constant-alist*)
                     (x86-lap-directive frag-list :align 3)
                     (dolist (double-pair *x862-double-float-constant-alist*)
                       (destructuring-bind (dfloat . lab) double-pair
                         (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))
                         (multiple-value-bind (high low)
                             (x862-double-float-bits dfloat)
                           (x86-lap-directive frag-list :long low)
                           (x86-lap-directive frag-list :long high))))
                     (dolist (single-pair *x862-single-float-constant-alist*)
                       (destructuring-bind (sfloat . lab) single-pair
                         (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))
                         (let* ((val (single-float-bits sfloat)))
                           (x86-lap-directive frag-list :long val)))))
                   (x86-lap-directive frag-list :align 3)
                   (x86-lap-directive frag-list :quad x8664::function-boundary-marker)
                   (emit-x86-lap-label frag-list end-code-tag)
                   (dolist (c (reverse *x862-constant-alist*))
                     (let* ((vinsn-label (cdr c)))
                       (or (vinsn-label-info vinsn-label)
                           (setf (vinsn-label-info vinsn-label)
                                 (find-or-create-x86-lap-label
                                  vinsn-label)))
                       (emit-x86-lap-label frag-list vinsn-label)
                       (x86-lap-directive frag-list :quad 0)))
                 
                   (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc)))
                     (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
                   (let* ((function-debugging-info (afunc-lfun-info afunc)))
                     (when (or function-debugging-info lambda-form *x862-record-symbols*)
                       (if lambda-form (setq function-debugging-info 
                                             (list* 'function-lambda-expression lambda-form function-debugging-info)))
                       (if *x862-record-symbols*
                         (setq function-debugging-info (nconc (list 'function-symbol-map *x862-recorded-symbols*)
                                                              function-debugging-info)))
                       (setq bits (logior (ash 1 $lfbits-symmap-bit) bits))
                       (setq debug-info function-debugging-info)))
                   (unless (or fname lambda-form *x862-recorded-symbols*)
                     (setq bits (logior (ash 1 $lfbits-noname-bit) bits)))
                   (unless (afunc-parent afunc)
                     (x862-fixup-fwd-refs afunc))
                   (setf (afunc-all-vars afunc) nil)
                   (setf (afunc-argsword afunc) bits)
                   (let* ((regsave-label (if (typep *x862-compiler-register-save-label* 'vinsn-note)
                                           (vinsn-label-info (vinsn-note-label *x862-compiler-register-save-label*))))
                          (regsave-mask (if regsave-label (x862-register-mask-byte
                                                           *x862-register-restore-count*)))
                          (regsave-addr (if regsave-label (x862-encode-register-save-ea
                                                           *x862-register-restore-ea*
                                                           *x862-register-restore-count*))))
                     (when debug-info
                       (x86-lap-directive frag-list :quad 0))
                     (when fname
                       (x86-lap-directive frag-list :quad 0))
                     (x86-lap-directive frag-list :quad 0)
                     (relax-frag-list frag-list)
                     (apply-relocs frag-list)
                     (fill-for-alignment frag-list)
                     (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr)
                     (setf (afunc-lfun afunc)
                           #+x86-target
                           (if (eq *host-backend* *target-backend*)
                             (create-x86-function fname frag-list *x862-constant-alist* bits debug-info)
                             (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info))
                           #-x86-target
                           (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info)))
                   (x862-digest-symbols)))))
          (backend-remove-labels))))
    afunc))


      
    
(defun x862-make-stack (size &optional (subtype target::subtag-s16-vector))
  (make-uarray-1 subtype size t 0 nil nil nil nil t nil))

(defun x862-fixup-fwd-refs (afunc)
  (dolist (f (afunc-inner-functions afunc))
    (x862-fixup-fwd-refs f))
  (let ((fwd-refs (afunc-fwd-refs afunc)))
    (when fwd-refs
      (let* ((native-x8664-functions #-x8664-target nil
                                     #+x8664-target (eq *target-backend*
                                                        *host-backend*))
             (v (if native-x8664-functions
                  (function-to-function-vector (afunc-lfun afunc))
                  (afunc-lfun afunc)))
             (vlen (uvsize v)))
        (declare (fixnum vlen))
        (dolist (ref fwd-refs)
          (let* ((ref-fun (afunc-lfun ref)))
            (do* ((i (if native-x8664-functions
                       (%function-code-words
                        (%function-vector-to-function v))
                       1)
                     (1+ i)))
                 ((= i vlen))
              (declare (fixnum i))
              (if (eq (%svref v i) ref)
                (setf (%svref v i) ref-fun)))))))))

(defun x862-digest-symbols ()
  (if *x862-recorded-symbols*
    (let* ((symlist *x862-recorded-symbols*)
           (len (length symlist))
           (syms (make-array len))
           (ptrs (make-array (%i+  (%i+ len len) len)))
           (i -1)
           (j -1))
      (declare (fixnum i j))
      (dolist (info symlist (progn (%rplaca symlist syms)
                                   (%rplacd symlist ptrs)))
        (flet ((label-address (note start-p sym)
                 (-
                  (let* ((label (vinsn-note-label note))
                         (lap-label (if label (vinsn-label-info label))))
                    (if lap-label
                      (x86-lap-label-address lap-label)
                      (compiler-bug "Missing or bad ~s label: ~s" 
                                    (if start-p 'start 'end) sym)))
                  x8664::fulltag-function)))
          (destructuring-bind (var sym startlab endlab) info
            (let* ((ea (var-ea var))
                   (ea-val (ldb (byte 16 0) ea)))
              (setf (aref ptrs (incf i)) (if (memory-spec-p ea)
                                           (logior (ash ea-val 6) #o77)
                                           ea-val)))
            (setf (aref syms (incf j)) sym)
            (setf (aref ptrs (incf i)) (label-address startlab t sym))
            (setf (aref ptrs (incf i)) (label-address endlab nil sym))))))))

(defun x862-decls (decls)
  (if (fixnump decls)
    (locally (declare (fixnum decls))
      (setq *x862-tail-allow* (neq 0 (%ilogand2 $decl_tailcalls decls))
            *x862-open-code-inline* (neq 0 (%ilogand2 $decl_opencodeinline decls))
            *x862-reckless* (neq 0 (%ilogand2 $decl_unsafe decls))
            *x862-trust-declarations* (neq 0 (%ilogand2 $decl_trustdecls decls))))))


(defun %x862-bigger-cdr-than (x y)
  (declare (cons x y))
  (> (the fixnum (cdr x)) (the fixnum (cdr y))))

;;; Return an unordered list of "varsets": each var in a varset can be
;;; assigned a register and all vars in a varset can be assigned the
;;; same register (e.g., no scope conflicts.)

(defun x862-partition-vars (vars)
  (labels ((var-weight (var)
             (let* ((bits (nx-var-bits var)))
               (declare (fixnum bits))
               (if (eql 0 (logand bits (logior
                                        (ash 1 $vbitpuntable)
                                        (ash -1 $vbitspecial)
                                        (ash 1 $vbitnoreg))))
                 (if (eql (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))
                          (logand bits (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))))
                   0
                   (%i+ (%ilogand $vrefmask bits) (%ilsr 8 (%ilogand $vsetqmask bits))))
                 0)))
           (sum-weights (varlist) 
             (let ((sum 0))
               (dolist (v varlist sum) (incf sum (var-weight v)))))
           (vars-disjoint-p (v1 v2)
             (if (eq v1 v2)
               nil
               (if (memq v1 (var-binding-info v2))
                 nil
                 (if (memq v2 (var-binding-info v1))
                   nil
                   t)))))
    (setq vars (%sort-list-no-key
                ;(delete-if #'(lambda (v) (eql (var-weight v) 0)) vars) 
                (do* ((handle (cons nil vars))
                      (splice handle))
                     ((null (cdr splice)) (cdr handle))                  
                  (declare (dynamic-extent handle) (type cons handle splice))
                  (if (eql 0 (var-weight (%car (cdr splice))))
                    (rplacd splice (%cdr (cdr splice)))
                    (setq splice (cdr splice))))
                #'(lambda (v1 v2) (%i> (var-weight v1) (var-weight v2)))))
    ;; This isn't optimal.  It partitions all register-allocatable
    ;; variables into sets such that
    ;; 1) no variable is a member of more than one set and
    ;; 2) all variables in a given set are disjoint from each other
    ;; A set might have exactly one member.
    ;; If a register is allocated for any member of a set, it's
    ;; allocated for all members of that set.
    (let* ((varsets nil))
      (do* ((all vars (cdr all)))
           ((null all))
        (let* ((var (car all)))
          (when (dolist (already varsets t)
                  (when (memq var (car already)) (return)))
            (let* ((varset (cons var nil)))
              (dolist (v (cdr all))
                (when (dolist (already varsets t)
                        (when (memq v (car already)) (return)))
                  (when (dolist (d varset t)
                          (unless (vars-disjoint-p v d) (return)))
                    (push v varset))))
              (let* ((weight (sum-weights varset)))
                (declare (fixnum weight))
                (if (>= weight 3)
                  (push (cons (nreverse varset) weight) varsets)))))))
      varsets)))

;;; Maybe globally allocate registers to symbols naming functions & variables,
;;; and to simple lexical variables.
(defun x862-allocate-global-registers (fcells vcells all-vars no-regs)
  (if no-regs
    (progn
      (dolist (c fcells) (%rplacd c nil))
      (dolist (c vcells) (%rplacd c nil))
      (values 0 nil))
    (let* ((maybe (x862-partition-vars all-vars)))
      (dolist (c fcells) 
        (if (>= (the fixnum (cdr c)) 3) (push c maybe)))
      (dolist (c vcells) 
        (if (>= (the fixnum (cdr c)) 3) (push c maybe)))
      (do* ((things (%sort-list-no-key maybe #'%x862-bigger-cdr-than) (cdr things))
            (n 0 (1+ n))
            (registers (target-arch-case (:x8664
                                          (list x8664::save0 x8664::save1 x8664::save2 x8664::save3))))
            (regno (pop registers) (pop registers))
            (constant-alist ()))
           ((or (null things) (= n *x862-target-num-save-regs*))
            (dolist (cell fcells) (%rplacd cell nil))
            (dolist (cell vcells) (%rplacd cell nil))
            (values n constant-alist))
        (declare (list things)
                 (fixnum n regno))
        (let* ((thing (car things)))
          (if (or (memq thing fcells)
                  (memq thing vcells))
            (push (cons thing regno) constant-alist)
            (dolist (var (car thing))
              (nx-set-var-bits var 
                               (%ilogior (%ilogand (%ilognot $vrefmask) (nx-var-bits var))
                                 regno
                                 (%ilsl $vbitreg 1))))))))))


    
;;; Vpush the last N non-volatile-registers.
(defun x862-save-nvrs (seg n)
  (declare (fixnum n))
  (when (> n 0)
    (setq *x862-compiler-register-save-label* (x862-emit-note seg :regsave))
    (with-x86-local-vinsn-macros (seg)
      (let* ((mask (target-arch-case (:x8664 x8664-nonvolatile-node-regs))))
        (dotimes (i n)
          (let* ((reg (1- (integer-length mask))))
            (x862-vpush-register seg reg :regsave reg 0)
            (setq mask (logandc2 mask (ash 1 reg)))))))
    (setq *x862-register-restore-ea* *x862-vstack*
          *x862-register-restore-count* n)))


;;; If there are an indefinite number of args/values on the vstack,
;;; we have to restore from a register that matches the compiler's
;;; notion of the vstack depth.  This can be computed by the caller 
;;; (sum of vsp & nargs, or copy of vsp  before indefinite number of 
;;; args pushed, etc.)


(defun x862-restore-nvrs (seg ea nregs &optional (can-pop t))
  (when (and ea nregs)
    (with-x86-local-vinsn-macros (seg)
      (let* ((mask (target-arch-case (:x8664 x8664-nonvolatile-node-regs)))
             (regs ()))
        (dotimes (i nregs)
          (let* ((reg (1- (integer-length mask))))
            (push reg regs)
            (setq mask (logandc2 mask (ash 1 reg)))))
        (cond (can-pop
               (let* ((diff-in-bytes (- *x862-vstack* ea)))
                 (unless (zerop diff-in-bytes)
                   (x862-adjust-vstack diff-in-bytes)
                   (! vstack-discard (floor diff-in-bytes *x862-target-node-size*)))
                 (dolist (reg regs)
                   (! vpop-register reg))))
              (t
               (dolist (reg regs)
                 (! vframe-load reg (- ea *x862-target-node-size*) ea)
                 (decf ea *x862-target-node-size*))))))))


(defun x862-bind-lambda (seg lcells req opt rest keys auxen optsupvloc passed-in-regs lexpr &optional inherited
                             &aux (vloc 0) (numopt (list-length (%car opt)))
                             (nkeys (list-length (%cadr keys))) 
                             reg)
  (declare (fixnum vloc))
  (x862-check-lcell-depth)
  (dolist (arg inherited)
    (if (memq arg passed-in-regs)
      (x862-set-var-ea seg arg (var-ea arg))
      (let* ((lcell (pop lcells)))
        (if (setq reg (x862-assign-register-var arg))
          (x862-init-regvar seg arg reg (x862-vloc-ea vloc))
          (x862-bind-var seg arg vloc lcell))
        (setq vloc (%i+ vloc *x862-target-node-size*)))))
  (dolist (arg req)
    (if (memq arg passed-in-regs)
      (x862-set-var-ea seg arg (var-ea arg))
      (let* ((lcell (pop lcells)))
        (if (setq reg (x862-assign-register-var arg))
          (x862-init-regvar seg arg reg (x862-vloc-ea vloc))
          (x862-bind-var seg arg vloc lcell))
        (setq vloc (%i+ vloc *x862-target-node-size*)))))
  (when opt
    (if (x862-hard-opt-p opt)
      (setq vloc (apply #'x862-initopt seg vloc optsupvloc lcells (nthcdr (- (length lcells) numopt) lcells) opt)
            lcells (nthcdr numopt lcells))

      (dolist (var (%car opt))
        (if (memq var passed-in-regs)
          (x862-set-var-ea seg var (var-ea var))
          (let* ((lcell (pop lcells)))
            (if (setq reg (x862-assign-register-var var))
              (x862-init-regvar seg var reg (x862-vloc-ea vloc))
              (x862-bind-var seg var vloc lcell))
            (setq vloc (+ vloc *x862-target-node-size*)))))))

  (when rest
    (if lexpr
      (progn
        (if (setq reg (x862-assign-register-var rest))
          (progn
            (x862-copy-register seg reg x8664::arg_z)
            (x862-set-var-ea seg rest reg))
            (let* ((loc *x862-vstack*))
              (x862-vpush-register seg x8664::arg_z :reserved)
              (x862-note-top-cell rest)
              (x862-bind-var seg rest loc *x862-top-vstack-lcell*))))
      (let* ((rvloc (+ vloc (* 2 *x862-target-node-size* nkeys))))
        (if (setq reg (x862-assign-register-var rest))
          (x862-init-regvar seg rest reg (x862-vloc-ea rvloc))
          (x862-bind-var seg rest rvloc (pop lcells))))))
    (when keys
      (apply #'x862-init-keys seg vloc lcells keys))
  (x862-seq-bind seg (%car auxen) (%cadr auxen)))


(defun x862-initopt (seg vloc spvloc lcells splcells vars inits spvars)
  (with-x86-local-vinsn-macros (seg)
    (dolist (var vars vloc)
      (let* ((initform (pop inits))
             (spvar (pop spvars))
             (lcell (pop lcells))
             (splcell (pop splcells))
             (reg (x862-assign-register-var var))
             (regloadedlabel (if reg (backend-get-next-label))))
        (unless (nx-null initform)
          (let ((skipinitlabel (backend-get-next-label)))
            (with-crf-target () crf
              (x862-compare-ea-to-nil seg crf (x862-make-compound-cd 0 skipinitlabel) (x862-vloc-ea spvloc)  x86::x86-e-bits t))
            (if reg
              (x862-form seg reg regloadedlabel initform)
              (x862-register-to-stack seg (x862-one-untargeted-reg-form seg initform ($ x8664::arg_z)) (x862-vloc-ea vloc)))
            (@ skipinitlabel)))
        (if reg
          (progn
            (x862-init-regvar seg var reg (x862-vloc-ea vloc))
            (@ regloadedlabel))
          (x862-bind-var seg var vloc lcell))
        (when spvar
          (if (setq reg (x862-assign-register-var spvar))
            (x862-init-regvar seg spvar reg (x862-vloc-ea spvloc))
            (x862-bind-var seg spvar spvloc splcell))))
      (setq vloc (%i+ vloc *x862-target-node-size*))
      (if spvloc (setq spvloc (%i+ spvloc *x862-target-node-size*))))))

(defun x862-init-keys (seg vloc lcells allow-others keyvars keysupp keyinits keykeys)
  (declare (ignore keykeys allow-others))
  (with-x86-local-vinsn-macros (seg)
    (dolist (var keyvars)
      (let* ((spvar (pop keysupp))
             (initform (pop keyinits))
             (reg (x862-assign-register-var var))
             (regloadedlabel (if reg (backend-get-next-label)))
             (var-lcell (pop lcells))
             (sp-lcell (pop lcells))
             (sploc (%i+ vloc *x862-target-node-size*)))
        (unless (nx-null initform)
          (let ((skipinitlabel (backend-get-next-label)))
            (with-crf-target () crf
              (x862-compare-ea-to-nil seg crf (x862-make-compound-cd 0 skipinitlabel) (x862-vloc-ea sploc)  x86::x86-e-bits t))
            (if reg
              (x862-form seg reg regloadedlabel initform)
              (x862-register-to-stack seg (x862-one-untargeted-reg-form seg initform ($ x8664::arg_z)) (x862-vloc-ea vloc)))
            (@ skipinitlabel)))
        (if reg
          (progn
            (x862-init-regvar seg var reg (x862-vloc-ea vloc))
            (@ regloadedlabel))
          (x862-bind-var seg var vloc var-lcell))
        (when spvar
          (if (setq reg (x862-assign-register-var spvar))
            (x862-init-regvar seg spvar reg (x862-vloc-ea sploc))
            (x862-bind-var seg spvar sploc sp-lcell))))
      (setq vloc (%i+ vloc (* 2 *x862-target-node-size*))))))

;;; Vpush register r, unless var gets a globally-assigned register.
;;; Return NIL if register was vpushed, else var.
(defun x862-vpush-arg-register (seg reg var)
  (when var
    (let* ((bits (nx-var-bits var)))
      (declare (fixnum bits))
      (if (logbitp $vbitreg bits)
        var
        (progn 
          (x862-vpush-register seg reg :reserved)
          nil)))))


;;; nargs has been validated, arguments defaulted and canonicalized.
;;; Save caller's context, then vpush any argument registers that
;;; didn't get global registers assigned to their variables.
;;; Return a list of vars/nils for each argument register 
;;;Â  (nil if vpushed, var if still in arg_reg).
(defun x862-argregs-entry (seg revargs &optional variable-args-entry)
  (with-x86-local-vinsn-macros (seg)
    (let* ((nargs (length revargs))
           (reg-vars ()))
      (declare (type (unsigned-byte 16) nargs))
      (unless variable-args-entry
        (if (<= nargs *x862-target-num-arg-regs*) ; caller didn't vpush anything
          (! save-lisp-context-no-stack-args)
          (let* ((offset (* (the fixnum (- nargs *x862-target-num-arg-regs*)) *x862-target-node-size*)))
            (declare (fixnum offset))
            (! save-lisp-context-offset offset))))
      (destructuring-bind (&optional zvar yvar xvar &rest stack-args) revargs
        (let* ((nstackargs (length stack-args)))
          (x862-set-vstack (* nstackargs *x862-target-node-size*))
          (dotimes (i nstackargs)
            (x862-new-vstack-lcell :reserved *x862-target-lcell-size* 0 nil))
          (if (>= nargs 3)
            (push (x862-vpush-arg-register seg ($ x8664::arg_x) xvar) reg-vars))
          (if (>= nargs 2)
            (push (x862-vpush-arg-register seg ($ x8664::arg_y) yvar) reg-vars))
          (if (>= nargs 1)
            (push (x862-vpush-arg-register seg ($ x8664::arg_z) zvar) reg-vars))))
      reg-vars)))

;;; Just required args.
;;; Since this is just a stupid bootstrapping port, always save 
;;; lisp context.
(defun x862-req-nargs-entry (seg rev-fixed-args)
  (let* ((nargs (length rev-fixed-args)))
    (declare (type (unsigned-byte 16) nargs))
    (with-x86-local-vinsn-macros (seg)
      (unless *x862-reckless*
        (! check-exact-nargs nargs))
      (x862-argregs-entry seg rev-fixed-args))))

;;; No more &optional args than register args; all &optionals default
;;; to NIL and none have supplied-p vars.  No &key/&rest.
(defun x862-simple-opt-entry (seg rev-opt-args rev-req-args)
  (let* ((min (length rev-req-args))
         (nopt (length rev-opt-args))
         (max (+ min nopt)))
    (declare (type (unsigned-byte 16) min nopt max))
    (with-x86-local-vinsn-macros (seg)
      (unless *x862-reckless*
        (if rev-req-args
          (! check-min-max-nargs min max)
          (! check-max-nargs max)))
      (if (> min $numx8664argregs)
        (! save-lisp-context-in-frame)
        (if (<= max $numx8664argregs)
          (! save-lisp-context-no-stack-args)
          (! save-lisp-context-variable-arg-count)))
      (if (= nopt 1)
        (! default-1-arg min)
        (if (= nopt 2)
          (! default-2-args min)
          (! default-3-args min)))
      (x862-argregs-entry seg (append rev-opt-args rev-req-args) t))))

;;; if "num-fixed" is > 0, we've already ensured that at least that many args
;;; were provided; that may enable us to generate better code for saving the
;;; argument registers.
;;; We're responsible for computing the caller's VSP and saving
;;; caller's state.
(defun x862-lexpr-entry (seg num-fixed)
  (with-x86-local-vinsn-macros (seg)
    (! save-lexpr-argregs num-fixed)
    ;; The "lexpr" (address of saved nargs register, basically
    ;; is now in arg_z
    (! build-lexpr-frame)
    (dotimes (i num-fixed)
      (! copy-lexpr-argument (- num-fixed i)))))


(defun x862-structured-initopt (seg lcells vloc context vars inits spvars)
  (with-x86-local-vinsn-macros (seg)
    (dolist (var vars vloc)
      (let* ((initform (pop inits))
             (spvar (pop spvars))
             (spvloc (%i+ vloc *x862-target-node-size*))
             (var-lcell (pop lcells))
             (sp-lcell (pop lcells)))
        (unless (nx-null initform)
          (let ((skipinitlabel (backend-get-next-label)))
            (with-crf-target () crf
              (x862-compare-ea-to-nil seg crf (x862-make-compound-cd 0 skipinitlabel) (x862-vloc-ea spvloc) x86::x86-e-bits t))
            (x862-register-to-stack seg (x862-one-untargeted-reg-form seg initform ($ x8664::arg_z)) (x862-vloc-ea vloc))
            (@ skipinitlabel)))
        (x862-bind-structured-var seg var vloc var-lcell context)
        (when spvar
          (x862-bind-var seg spvar spvloc sp-lcell)))
      (setq vloc (%i+ vloc (* 2 *x862-target-node-size*))))))



(defun x862-structured-init-keys (seg lcells vloc context allow-others keyvars keysupp keyinits keykeys)
  (declare (ignore keykeys allow-others))
  (with-x86-local-vinsn-macros (seg)
    (dolist (var keyvars)
      (let* ((spvar (pop keysupp))
             (initform (pop keyinits))
             (sploc (%i+ vloc *x862-target-node-size*))
             (var-lcell (pop lcells))
             (sp-reg ($ x8664::arg_z))
             (sp-lcell (pop lcells)))
        (unless (nx-null initform)
          (x862-stack-to-register seg (x862-vloc-ea sploc) sp-reg)
          (let ((skipinitlabel (backend-get-next-label)))
            (with-crf-target () crf
              (x862-compare-register-to-nil seg crf (x862-make-compound-cd 0 skipinitlabel) sp-reg x86::x86-e-bits t))
            (x862-register-to-stack seg (x862-one-untargeted-reg-form seg initform ($ x8664::arg_z)) (x862-vloc-ea vloc))
            (@ skipinitlabel)))
        (x862-bind-structured-var seg var vloc var-lcell context)
        (when spvar
          (x862-bind-var seg spvar sploc sp-lcell)))
      (setq vloc (%i+ vloc (* 2 *x862-target-node-size*))))))

(defun x862-vloc-ea (n &optional vcell-p)
  (setq n (make-memory-spec (dpb memspec-frame-address memspec-type-byte n)))
  (if vcell-p
    (make-vcell-memory-spec n)
    n))


(defun x862-form (seg vreg xfer form)
  (if (nx-null form)
    (x862-nil seg vreg xfer)
    (if (nx-t form)
      (x862-t seg vreg xfer)
      (let* ((op nil)
             (fn nil))
        (if (and (consp form)
                 (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
          (if (and (null vreg)
                   (%ilogbitp operator-acode-subforms-bit op)
                   (%ilogbitp operator-assignment-free-bit op))
            (dolist (f (%cdr form) (x862-branch seg xfer))
              (x862-form seg nil nil f ))
            (apply fn seg vreg xfer (%cdr form)))
          (compiler-bug "x862-form ? ~s" form))))))

;;; dest is a float reg - form is acode
(defun x862-form-float (seg freg xfer form)
  (declare (ignore xfer))
  (when (or (nx-null form)(nx-t form))(compiler-bug "x862-form to freg ~s" form))
  (when (and (= (get-regspec-mode freg) hard-reg-class-fpr-mode-double)
             (x862-form-typep form 'double-float))
    ;; kind of screwy - encoding the source type in the dest register spec
    (set-node-regspec-type-modes freg hard-reg-class-fpr-type-double))
  (let* ((fn nil))
    (if (and (consp form)
             (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (acode-operator form)))))      
      (apply fn seg freg nil (%cdr form))
      (compiler-bug "x862-form ? ~s" form))))



(defun x862-form-typep (form type)
  (acode-form-typep form type *x862-trust-declarations*)
)

(defun x862-form-type (form)
  (acode-form-type form *x862-trust-declarations*))
  
(defun x862-use-operator (op seg vreg xfer &rest forms)
  (declare (dynamic-extent forms))
  (apply (svref *x862-specials* (%ilogand operator-id-mask op)) seg vreg xfer forms))

;;; Returns true iff lexical variable VAR isn't setq'ed in FORM.
;;; Punts a lot ...
(defun x862-var-not-set-by-form-p (var form)
  (or (not (%ilogbitp $vbitsetq (nx-var-bits var)))
      (x862-setqed-var-not-set-by-form-p var form)))

(defun x862-setqed-var-not-set-by-form-p (var form)
  (setq form (acode-unwrapped-form form))
  (or (atom form)
      (x86-constant-form-p form)
      (x862-lexical-reference-p form)
      (let ((op (acode-operator form))
            (subforms nil))
        (if (eq op (%nx1-operator setq-lexical))
          (and (neq var (cadr form))
               (x862-setqed-var-not-set-by-form-p var (caddr form)))
          (and (%ilogbitp operator-side-effect-free-bit op)
               (flet ((not-set-in-formlist (formlist)
                        (dolist (subform formlist t)
                          (unless (x862-setqed-var-not-set-by-form-p var subform) (return)))))
                 (if
                   (cond ((%ilogbitp operator-acode-subforms-bit op) (setq subforms (%cdr form)))
                         ((%ilogbitp operator-acode-list-bit op) (setq subforms (cadr form))))
                   (not-set-in-formlist subforms)
                   (and (or (eq op (%nx1-operator call))
                            (eq op (%nx1-operator lexical-function-call)))
                        (x862-setqed-var-not-set-by-form-p var (cadr form))
                        (setq subforms (caddr form))
                        (not-set-in-formlist (car subforms))
                        (not-set-in-formlist (cadr subforms))))))))))

(defun x862-check-fixnum-overflow (seg target &optional labelno)
  (with-x86-local-vinsn-macros (seg)
    (if *x862-open-code-inline*
      (let* ((no-overflow (backend-get-next-label)))
        (! set-bigits-and-header-for-fixnum-overflow target (aref *backend-labels* (or labelno no-overflow)))
        (! %allocate-uvector target)
        (! set-bigits-after-fixnum-overflow target)
        (when labelno
          (-> labelno))
        (@ no-overflow))
      (if labelno
        (! fix-fixnum-overflow-ool-and-branch target (aref *backend-labels* labelno))
        (! fix-fixnum-overflow-ool target)))))

(defun x862-nil (seg vreg xfer)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (if (eq vreg :push)
      (progn
        (! vpush-fixnum x8664::nil-value)
        (^))
      (progn
        (if (x862-for-value-p vreg)
          (ensuring-node-target (target vreg)
            (! load-nil target)))
        (x862-branch seg (x862-cd-false xfer))))))

(defun x862-t (seg vreg xfer)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (if (eq vreg :push)
      (progn
        (! vpush-fixnum x8664::t-value)
        (^))
      (progn
        (if (x862-for-value-p vreg)
          (ensuring-node-target (target vreg)
            (! load-t target)))
        (x862-branch seg (x862-cd-true xfer))))))

(defun x862-for-value-p (vreg)
  (and vreg (not (backend-crf-p vreg))))

(defun x862-mvpass (seg form &optional xfer)
  (with-x86-local-vinsn-macros (seg)
    (x862-form seg  ($ x8664::arg_z) (logior (or xfer 0) $backend-mvpass-mask) form)))

(defun x862-adjust-vstack (delta)
  (x862-set-vstack (%i+ *x862-vstack* delta)))

(defun x862-set-vstack (new)
  (setq *x862-vstack* new))


;;; Emit a note at the end of the segment.
(defun x862-emit-note (seg class &rest info)
  (declare (dynamic-extent info))
  (let* ((note (make-vinsn-note class info)))
    (append-dll-node (vinsn-note-label note) seg)
    note))

;;; Emit a note immediately before the target vinsn.
(defun x86-prepend-note (vinsn class &rest info)
  (declare (dynamic-extent info))
  (let* ((note (make-vinsn-note class info)))
    (insert-dll-node-before (vinsn-note-label note) vinsn)
    note))

(defun x862-close-note (seg note)
  (let* ((end (close-vinsn-note note)))
    (append-dll-node (vinsn-note-label end) seg)
    end))






(defun x862-stack-to-register (seg memspec reg)
  (with-x86-local-vinsn-macros (seg)
    (let* ((offset (memspec-frame-address-offset memspec)))
      (if (and *x862-tos-reg*
               (= offset (- *x862-vstack* *x862-target-node-size*)))
        (x862-copy-register seg reg *x862-tos-reg*)
        (! vframe-load reg offset  *x862-vstack*)))))

(defun x862-lcell-to-register (seg lcell reg)
  (with-x86-local-vinsn-macros (seg)
    (! lcell-load reg lcell (x862-vstack-mark-top))))

(defun x862-register-to-lcell (seg reg lcell)
  (with-x86-local-vinsn-macros (seg)
    (! lcell-store reg lcell (x862-vstack-mark-top))))

(defun x862-register-to-stack (seg reg memspec)
  (with-x86-local-vinsn-macros (seg)
    (! vframe-store reg (memspec-frame-address-offset memspec) *x862-vstack*)))


(defun x862-ea-open (ea)
  (if (and ea (not (typep ea 'lreg)) (addrspec-vcell-p ea))
    (make-memory-spec (memspec-frame-address-offset ea))
    ea))

(defun x862-set-NARGS (seg n)
  (if (> n call-arguments-limit)
    (error "~s exceeded." call-arguments-limit)
    (with-x86-local-vinsn-macros (seg)
      (! set-nargs n))))

(defun x862-assign-register-var (v)
  (let ((bits (nx-var-bits v)))
    (when (%ilogbitp $vbitreg bits)
      (%ilogand bits $vrefmask))))

(defun x862-single-float-bits (the-sf)
  (single-float-bits the-sf))

(defun x862-double-float-bits (the-df)
  (double-float-bits the-df))

(defun x862-push-immediate (seg xfer form)
  (with-x86-local-vinsn-macros (seg)
    (if (typep form 'character)
      (! vpush-fixnum (logior (ash (char-code form) 8) x8664::subtag-character))
      (let* ((reg (x862-register-constant-p form)))
        (if reg
          (! vpush-register reg)
          (let* ((lab (x86-immediate-label form)))
            (! vpush-constant lab)))))
    (x862-branch seg xfer)))

      
(pushnew (%nx1-operator immediate) *x862-operator-supports-push*)  
(defun x862-immediate (seg vreg xfer form)
  (if (eq vreg :push)
    (x862-push-immediate seg xfer form)
    (with-x86-local-vinsn-macros (seg vreg xfer)
      (if vreg
        (if (and (= (hard-regspec-class vreg) hard-reg-class-fpr)
                 (or (and (typep form 'double-float) (= (get-regspec-mode vreg) hard-reg-class-fpr-mode-double))
                     (and (typep form 'short-float)(= (get-regspec-mode vreg) hard-reg-class-fpr-mode-single))))
          (if (zerop form)
            (if (eql form 0.0d0)
              (! zero-double-float-register vreg)
              (! zero-single-float-register vreg))
            (if (typep form 'short-float)
              (let* ((lab (x86-single-float-constant-label form)))
                (! load-single-float-constant vreg lab))
              (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)))))
        (if (and (listp form) *load-time-eval-token* (eq (car form) *load-time-eval-token*))
          (x862-store-immediate seg form ($ x8664::temp0))))
      (^))))

(defun x862-register-constant-p (form)
  (and (consp form)
           (or (memq form *x862-vcells*)
               (memq form *x862-fcells*))
           (%cdr form)))

(defun x862-store-immediate (seg imm dest)
  (with-x86-local-vinsn-macros (seg)
    (let* ((reg (x862-register-constant-p imm)))
      (if reg
        (x862-copy-register seg dest reg)
        (let* ((lab (x86-immediate-label imm)))
          (! ref-constant dest lab)))
      dest)))


;;; Returns label iff form is (local-go <tag>) and can go without adjusting stack.
(defun x862-go-label (form)
  (let ((current-stack (x862-encode-stack)))
    (while (and (acode-p form) (or (eq (acode-operator form) (%nx1-operator progn))
                                   (eq (acode-operator form) (%nx1-operator local-tagbody))))
      (setq form (caadr form)))
    (when (acode-p form)
      (let ((op (acode-operator form)))
        (if (and (eq op (%nx1-operator local-go))
                 (x862-equal-encodings-p (%caddr (%cadr form)) current-stack))
          (%cadr (%cadr form))
          (if (and (eq op (%nx1-operator local-return-from))
                   (nx-null (caddr form)))
            (let ((tagdata (car (cadr form))))
              (and (x862-equal-encodings-p (cdr tagdata) current-stack)
                   (null (caar tagdata))
                   (< 0 (cdar tagdata) $backend-mvpass)
                   (cdar tagdata)))))))))

(defun x862-single-valued-form-p (form)
  (setq form (acode-unwrapped-form form))
  (or (nx-null form)
      (nx-t form)
      (if (acode-p form)
        (let ((op (acode-operator form)))
          (or (%ilogbitp operator-single-valued-bit op)
              (and (eql op (%nx1-operator values))
                   (let ((values (cadr form)))
                     (and values (null (cdr values)))))
              nil                       ; Learn about functions someday
              )))))


(defun x862-box-s32 (seg node-dest s32-src)
  (with-x86-local-vinsn-macros (seg)
    (if (target-arch-case
         
         (:x8664 t))
      (! box-fixnum node-dest s32-src)
      (let* ((arg_z ($ x8664::arg_z))
             (imm0 ($ x8664::imm0 :mode :s32)))
        (x862-copy-register seg imm0 s32-src)
        (! call-subprim (subprim-name->offset '.SPmakes32))
        (x862-copy-register seg node-dest arg_z)))))

(defun x862-box-s64 (seg node-dest s64-src)
  (with-x86-local-vinsn-macros (seg)
    (if (target-arch-case
         (:x8664 *x862-open-code-inline*))
      (let* ((no-overflow (backend-get-next-label)))
        (! %set-z-flag-if-s64-fits-in-fixnum node-dest s64-src)
        (! cbranch-true (aref *backend-labels* no-overflow) x86::x86-e-bits)
        (! setup-bignum-alloc-for-s64-overflow s64-src)
        (! %allocate-uvector node-dest)
        (! set-bigits-after-fixnum-overflow node-dest)
        (@ no-overflow))
      (let* ((arg_z ($ x8664::arg_z))
             (imm0 (make-wired-lreg x8664::imm0 :mode (get-regspec-mode s64-src))))
        (x862-copy-register seg imm0 s64-src)
        (! call-subprim (subprim-name->offset '.SPmakes64))
        (x862-copy-register seg node-dest arg_z)))))

(defun x862-box-u32 (seg node-dest u32-src)
  (with-x86-local-vinsn-macros (seg)
    (if (target-arch-case
         
         (:x8664 t))
      (! box-fixnum node-dest u32-src)
      (let* ((arg_z ($ x8664::arg_z))
             (imm0 ($ x8664::imm0 :mode :u32)))
        (x862-copy-register seg imm0 u32-src)
        (! call-subprim (subprim-name->offset '.SPmakeu32))
        (x862-copy-register seg node-dest arg_z)))))

(defun x862-box-u64 (seg node-dest u64-src)
  (with-x86-local-vinsn-macros (seg)
    (if (target-arch-case
         
         (:x8664 *x862-open-code-inline*))
      (let* ((no-overflow (backend-get-next-label)))
        (! %set-z-flag-if-u64-fits-in-fixnum node-dest u64-src)
        (! cbranch-true (aref *backend-labels* no-overflow) x86::x86-e-bits)
        (! setup-bignum-alloc-for-u64-overflow u64-src)
        (! %allocate-uvector node-dest)
        (! set-bigits-after-fixnum-overflow node-dest)
        (@ no-overflow))
      (let* ((arg_z ($ x8664::arg_z))
             (imm0 ($ x8664::imm0 :mode :u64)))
        (x862-copy-register seg imm0 u64-src)
        (! call-subprim (subprim-name->offset '.SPmakeu64))
        (x862-copy-register seg node-dest arg_z)))))

(defun x862-double->heap (seg dest src)
  (with-x86-local-vinsn-macros (seg)
    (! setup-double-float-allocation)
    (! %allocate-uvector dest)
    (! set-double-float-value dest src)))


(defun x862-vref1 (seg vreg xfer type-keyword src unscaled-idx index-known-fixnum)  
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (when vreg
      (let* ((arch (backend-target-arch *target-backend*))
             (is-node (member type-keyword (arch::target-gvector-types arch)))
             (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch)))

             (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
             (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
             (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
             (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
             (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector)))
             (vreg-class (and (not (eq vreg :push)) (hard-regspec-class vreg)))
             (vreg-mode
              (if (eql vreg-class hard-reg-class-gpr)
                (get-regspec-mode vreg)
                hard-reg-class-gpr-mode-invalid)))
        (cond
          (is-node
           (if (eq vreg :push)
             (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
               (! push-misc-ref-c-node  src index-known-fixnum)
               (! push-misc-ref-node src unscaled-idx))
             (ensuring-node-target (target vreg)
               (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
                 (! misc-ref-c-node target src index-known-fixnum)
                 (! misc-ref-node target src unscaled-idx)))))
          (is-32-bit
           (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-32-bit-constant-index arch)))
             (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-c-single-float fp-val src index-known-fixnum)
                      (if (eql 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-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)))))))))
          (is-8-bit
           (with-imm-target () temp
             (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-8-bit-constant-index arch)))
               (if is-signed
                 (! 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))))
             (if (eq type-keyword :simple-string)
               (ensuring-node-target (target vreg)
                 (! u32->char target temp))
               (if (and (= vreg-mode hard-reg-class-gpr-mode-u8)
                        (eq type-keyword :unsigned-8-bit-vector))
                 (x862-copy-register seg vreg temp)
                 (ensuring-node-target (target vreg)
                   (! box-fixnum target temp))))))
          (is-16-bit
           (with-imm-target () temp
             (ensuring-node-target (target vreg)
               (if (and index-known-fixnum
                        (<= index-known-fixnum (arch::target-max-16-bit-constant-index arch)))
                 (if is-signed
                   (! 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))))
               (! box-fixnum target temp))))
          ;; Down to the dregs.
          (is-64-bit
           (case type-keyword
             (:double-float-vector
              (with-fp-target () (fp-val :double-float)
                (if (and (eql vreg-class hard-reg-class-fpr)
                         (eql vreg-mode hard-reg-class-fpr-mode-double))
                  (setq fp-val vreg))
                (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
                  (! misc-ref-c-double-float fp-val src index-known-fixnum)
                  (progn
                    (if index-known-fixnum
                      (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3))))
                    (! misc-ref-double-float fp-val src unscaled-idx)))
                (if (eq vreg-class hard-reg-class-fpr)
                  (<- fp-val)
                  (ensuring-node-target (target vreg)
                    (x862-double->heap seg target fp-val)))))
             ((:signed-64-bit-vector :fixnum-vector)
              (ensuring-node-target (target vreg)

                (with-imm-target () (s64-reg :s64)
                  (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
                    (! misc-ref-c-s64 s64-reg src index-known-fixnum)
                    (progn
                      (if index-known-fixnum
                        (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3))))
                      (! misc-ref-s64 s64-reg src unscaled-idx)))
                  (if (eq type-keyword :fixnum-vector)
                    (! box-fixnum target s64-reg)
                    (x862-box-s64 seg target s64-reg)))))
             (t
                (with-imm-target () (u64-reg :u64)
                  (if (eql vreg-mode hard-reg-class-gpr-mode-u64)
                    (setq u64-reg vreg))
                  (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
                    (! misc-ref-c-u64 u64-reg src index-known-fixnum)
                    (progn
                      (if index-known-fixnum
                        (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3))))
                      (! misc-ref-u64 u64-reg src unscaled-idx)))
                  (unless (eq u64-reg vreg)
                    (ensuring-node-target (target vreg)
                      (x862-box-u64 seg target u64-reg)))))))
          (t
           (unless is-1-bit
             (nx-error "~& unsupported vector type: ~s"
                       type-keyword))
           (ensuring-node-target (target vreg)
             (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))))))))
    (^)))

;;; safe = T means assume "vector" is miscobj, do bounds check.
;;; safe = fixnum means check that subtag of vector = "safe" and do
;;;Â  Â  Â  Â  bounds check.
;;; safe = nil means crash&burn.
;;; This mostly knows how to reference the elements of an immediate miscobj.
(defun x862-vref (seg vreg xfer type-keyword vector index safe)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (if (null vreg)
      (progn
        (x862-form seg nil nil vector)
        (x862-form seg nil xfer index))
      (let* ((index-known-fixnum (acode-fixnum-form-p index))
             (unscaled-idx nil)
             (src nil))
        (if (or safe (not index-known-fixnum))
          (multiple-value-setq (src unscaled-idx)
            (x862-two-untargeted-reg-forms seg vector x8664::arg_y index x8664::arg_z))
          (setq src (x862-one-untargeted-reg-form seg vector x8664::arg_z)))
        (when safe
          (if (typep safe 'fixnum)
            (! trap-unless-typecode= src safe))
          (unless index-known-fixnum
            (! trap-unless-fixnum unscaled-idx))
          (! check-misc-bound unscaled-idx src))
        (x862-vref1 seg vreg xfer type-keyword src unscaled-idx index-known-fixnum)))))



(defun x862-aset2 (seg vreg xfer  array i j new safe type-keyword  dim0 dim1)
  (with-x86-local-vinsn-macros (seg target)
    (let* ((i-known-fixnum (acode-fixnum-form-p i))
           (j-known-fixnum (acode-fixnum-form-p j))
           (arch (backend-target-arch *target-backend*))
           (is-node (member type-keyword (arch::target-gvector-types arch)))
           (constval (x862-constant-value-ok-for-type-keyword type-keyword new))
           (needs-memoization (and is-node (x862-acode-needs-memoization new)))
           (src)
           (unscaled-i)
           (unscaled-j)
           (val-reg (x862-target-reg-for-aset vreg type-keyword))
           (constidx
            (and dim0 dim1 i-known-fixnum j-known-fixnum
                 (>= i-known-fixnum 0)
                 (>= j-known-fixnum 0)
                 (< i-known-fixnum dim0)
                 (< j-known-fixnum dim1)
                 (+ (* i-known-fixnum dim1) j-known-fixnum))))
      (progn
        (if constidx
          (multiple-value-setq (src val-reg)
            (x862-two-targeted-reg-forms seg array ($ x8664::temp0) new val-reg))
          (multiple-value-setq (src unscaled-i unscaled-j val-reg)
            (if needs-memoization
              (progn
                (x862-four-targeted-reg-forms seg
                                              array ($ x8664::temp0)
                                              i ($ x8664::arg_x)
                                              j ($ x8664::arg_y)
                                              new val-reg)
                (values ($ x8664::temp0) ($ x8664::arg_x) ($ x8664::arg_y) ($ x8664::arg_z)))
              (x862-four-untargeted-reg-forms seg
                                              array ($ x8664::temp0)
                                              i ($ x8664::arg_x)
                                              j ($ x8664::arg_y)
                                              new val-reg))))
        (let* ((*available-backend-imm-temps* *available-backend-imm-temps*))
          (when (and (= (hard-regspec-class val-reg) hard-reg-class-gpr)
                     (logbitp (hard-regspec-value val-reg)
                              *backend-imm-temps*))
            (use-imm-temp (hard-regspec-value val-reg)))
          (when safe      
            (when (typep safe 'fixnum)
              (! trap-unless-simple-array-2
                 src
                 (dpb safe target::arrayH.flags-cell-subtag-byte
                      (ash 1 $arh_simple_bit))
                 (nx-error-for-simple-2d-array-type type-keyword)))
            (unless i-known-fixnum
              (! trap-unless-fixnum unscaled-i))
            (unless j-known-fixnum
              (! trap-unless-fixnum unscaled-j)))
          (with-imm-target () dim1
            (let* ((idx-reg ($ x8664::arg_y)))
              (if constidx
                (if needs-memoization
                  (x862-lri seg x8664::arg_y (ash constidx *x862-target-fixnum-shift*)))
                (progn
                  (if safe                  
                    (! check-2d-bound dim1 unscaled-i unscaled-j src)
                    (! 2d-dim1 dim1 src))
                  (! 2d-unscaled-index idx-reg dim1 unscaled-i unscaled-j)))
              (let* ((v ($ x8664::arg_x)))
                (! array-data-vector-ref v src)
                (x862-vset1 seg vreg xfer type-keyword v idx-reg constidx val-reg (x862-unboxed-reg-for-aset seg type-keyword val-reg safe constval) constval needs-memoization)))))))))


(defun x862-aset3 (seg vreg xfer  array i j k new safe type-keyword  dim0 dim1 dim2)
  (with-x86-local-vinsn-macros (seg target)
    (let* ((i-known-fixnum (acode-fixnum-form-p i))
           (j-known-fixnum (acode-fixnum-form-p j))
           (k-known-fixnum (acode-fixnum-form-p k))
           (arch (backend-target-arch *target-backend*))
           (is-node (member type-keyword (arch::target-gvector-types arch)))
           (constval (x862-constant-value-ok-for-type-keyword type-keyword new))
           (needs-memoization (and is-node (x862-acode-needs-memoization new)))
           (src)
           (unscaled-i)
           (unscaled-j)
           (unscaled-k)
           (val-reg (x862-target-reg-for-aset vreg type-keyword))
           (constidx
            (and dim0 dim1 dim2 i-known-fixnum j-known-fixnum k-known-fixnum
                 (>= i-known-fixnum 0)
                 (>= j-known-fixnum 0)
                 (>= k-known-fixnum 0)
                 (< i-known-fixnum dim0)
                 (< j-known-fixnum dim1)
                 (< k-known-fixnum dim2)
                 (+ (* i-known-fixnum dim1 dim2)
                    (* j-known-fixnum dim2)
                    k-known-fixnum))))
      (progn
        (if constidx
          (multiple-value-setq (src val-reg)
            (x862-two-targeted-reg-forms seg array ($ x8664::temp0) new val-reg))
          (progn
            (setq src ($ x8664::temp1)
                  unscaled-i ($ x8664::temp0)
                  unscaled-j ($ x8664::arg_x)
                  unscaled-k ($ x8664::arg_y))
            (x862-push-register
             seg
             (x862-one-untargeted-reg-form seg array ($ x8664::arg_z)))
            (x862-four-targeted-reg-forms seg
                                          i ($ x8664::temp0)
                                          j ($ x8664::arg_x)
                                          k ($ x8664::arg_y)
                                          new val-reg)
            (x862-pop-register seg src)))
        (let* ((*available-backend-imm-temps* *available-backend-imm-temps*))
          (when (and (= (hard-regspec-class val-reg) hard-reg-class-gpr)
                     (logbitp (hard-regspec-value val-reg)
                              *backend-imm-temps*))
            (use-imm-temp (hard-regspec-value val-reg)))
        
          (when safe      
            (when (typep safe 'fixnum)
              (! trap-unless-simple-array-3
                 src
                 (dpb safe target::arrayH.flags-cell-subtag-byte
                      (ash 1 $arh_simple_bit))
                 (nx-error-for-simple-3d-array-type type-keyword)))
            (unless i-known-fixnum
              (! trap-unless-fixnum unscaled-i))
            (unless j-known-fixnum
              (! trap-unless-fixnum unscaled-j))
            (unless k-known-fixnum
              (! trap-unless-fixnum unscaled-k)))
          (with-imm-target () dim1
            (with-imm-target (dim1) dim2
              (let* ((idx-reg ($ x8664::arg_y)))
                (if constidx
                  (when needs-memoization
                    (x862-lri seg idx-reg (ash constidx *x862-target-fixnum-shift*)))
                  (progn
                    (if safe                  
                      (! check-3d-bound dim1 dim2 unscaled-i unscaled-j unscaled-k src)
                      (! 3d-dims dim1 dim2 src))
                    (! 3d-unscaled-index idx-reg dim1 dim2 unscaled-i unscaled-j unscaled-k)))
                (let* ((v ($ x8664::arg_x)))
                  (! array-data-vector-ref v src)
                  (x862-vset1 seg vreg xfer type-keyword v idx-reg constidx val-reg (x862-unboxed-reg-for-aset seg type-keyword val-reg safe constval) constval needs-memoization))))))))))


(defun x862-aref2 (seg vreg xfer array i j safe typekeyword &optional dim0 dim1)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (let* ((i-known-fixnum (acode-fixnum-form-p i))
           (j-known-fixnum (acode-fixnum-form-p j))
           (src)
           (unscaled-i)
           (unscaled-j)
           (constidx
            (and dim0 dim1 i-known-fixnum j-known-fixnum
                 (>= i-known-fixnum 0)
                 (>= j-known-fixnum 0)
                 (< i-known-fixnum dim0)
                 (< j-known-fixnum dim1)
                 (+ (* i-known-fixnum dim1) j-known-fixnum))))
      (if constidx
        (setq src (x862-one-targeted-reg-form seg array ($ x8664::arg_z)))
        (multiple-value-setq (src unscaled-i unscaled-j)
          (x862-three-untargeted-reg-forms seg
                                           array x8664::arg_x
                                           i x8664::arg_y
                                           j x8664::arg_z)))
      (when safe        
        (when (typep safe 'fixnum)
          (! trap-unless-simple-array-2
             src
             (dpb safe target::arrayH.flags-cell-subtag-byte
                  (ash 1 $arh_simple_bit))
             (nx-error-for-simple-2d-array-type typekeyword)))
        (unless i-known-fixnum
          (! trap-unless-fixnum unscaled-i))
        (unless j-known-fixnum
          (! trap-unless-fixnum unscaled-j)))
      (with-node-target (src) idx-reg
        (with-imm-target () dim1
          (unless constidx
            (if safe                    
              (! check-2d-bound dim1 unscaled-i unscaled-j src)
              (! 2d-dim1 dim1 src))
            (! 2d-unscaled-index idx-reg dim1 unscaled-i unscaled-j))
          (with-node-target (idx-reg) v
            (! array-data-vector-ref v src)
            (x862-vref1 seg vreg xfer typekeyword v idx-reg constidx)))))))

(defun x862-aref3 (seg vreg xfer array i j k safe typekeyword &optional dim0 dim1 dim2)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (let* ((i-known-fixnum (acode-fixnum-form-p i))
           (j-known-fixnum (acode-fixnum-form-p j))
           (k-known-fixnum (acode-fixnum-form-p k))
           (src)
           (unscaled-i)
           (unscaled-j)
           (unscaled-k)
           (constidx
            (and dim0 dim1 i-known-fixnum j-known-fixnum k-known-fixnum
                 (>= i-known-fixnum 0)
                 (>= j-known-fixnum 0)
                 (>= k-known-fixnum 0)
                 (< i-known-fixnum dim0)
                 (< j-known-fixnum dim1)
                 (< k-known-fixnum dim2)
                 (+ (* i-known-fixnum dim1 dim2)
                    (* j-known-fixnum dim2)
                    k-known-fixnum))))
      (if constidx
        (setq src (x862-one-targeted-reg-form seg array ($ x8664::arg_z)))
        (multiple-value-setq (src unscaled-i unscaled-j unscaled-k)
          (x862-four-untargeted-reg-forms seg
                                           array x8664::temp0
                                           i x8664::arg_x
                                           j x8664::arg_y
                                           k x8664::arg_z)))
      (when safe        
        (when (typep safe 'fixnum)
          (! trap-unless-simple-array-3
             src
             (dpb safe target::arrayH.flags-cell-subtag-byte
                  (ash 1 $arh_simple_bit))
             (nx-error-for-simple-3d-array-type typekeyword)))
        (unless i-known-fixnum
          (! trap-unless-fixnum unscaled-i))
        (unless j-known-fixnum
          (! trap-unless-fixnum unscaled-j))
        (unless k-known-fixnum
          (! trap-unless-fixnum unscaled-k)))
      (with-node-target (src) idx-reg
        (with-imm-target () dim1
          (with-imm-target (dim1) dim2
            (unless constidx
              (if safe                    
                (! check-3d-bound dim1 dim2 unscaled-i unscaled-j unscaled-k src)
                (! 3d-dims dim1 dim2 src))
              (! 3d-unscaled-index idx-reg dim1 dim2 unscaled-i unscaled-j unscaled-k))))
        (with-node-target (idx-reg) v
          (! array-data-vector-ref v src)
          (x862-vref1 seg vreg xfer typekeyword v idx-reg constidx))))))



(defun x862-natural-vset (seg vreg xfer vector index value safe)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (let* ((index-known-fixnum (acode-fixnum-form-p index))
           (arch (backend-target-arch *target-backend*))
           (src nil)
           (unscaled-idx nil))
      (with-imm-target () (target :natural)
        (if (or safe (not index-known-fixnum))
          (multiple-value-setq (src unscaled-idx target)
            (x862-three-untargeted-reg-forms seg vector x8664::arg_y index x8664::arg_z value (or vreg target)))
          (multiple-value-setq (src target)
            (x862-two-untargeted-reg-forms seg vector x8664::arg_y value (or vreg target))))
        (when safe
          (with-imm-temps (target) ()   ; Don't use target in type/bounds check
            (if (typep safe 'fixnum)
              (! trap-unless-typecode= src safe))
            (unless index-known-fixnum
              (! trap-unless-fixnum unscaled-idx))
            (! check-misc-bound unscaled-idx src)))
        (target-arch-case
         
         (:x8664
          (if (and index-known-fixnum
                   (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
            (! misc-set-c-u64 target src index-known-fixnum)
            (progn
              (if index-known-fixnum
                (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3))))
              (! misc-set-u64 target src unscaled-idx)))))
        (<- target)                     ; should be a no-op in this case
        (^)))))


(defun x862-constant-value-ok-for-type-keyword (type-keyword form)
  (let* ((arch (backend-target-arch *target-backend*))
         (is-node  (member type-keyword (arch::target-gvector-types arch))))
    (if is-node
      (cond ((eq form *nx-nil*)
             (arch::target-nil-value arch))
            ((eq form *nx-t*)
             (+ (arch::target-nil-value arch) (arch::target-t-offset arch)))
            (t
             (let* ((fixval (acode-fixnum-form-p form)))
               (if fixval
                 (ash fixval (arch::target-fixnum-shift arch))))))
      (if (and (acode-p form)
               (or (eq (acode-operator form) (%nx1-operator immediate))
                   (eq (acode-operator form) (%nx1-operator fixnum))))
        (let* ((val (%cadr form))

               (typep (cond ((eq type-keyword :signed-32-bit-vector)
                             (typep val '(signed-byte 32)))
                            ((eq type-keyword :single-float-vector)
                             (typep val 'short-float))
                            ((eq type-keyword :double-float-vector)
                             (typep val 'double-float))
                            ((eq type-keyword :simple-string)
                             (typep val 'base-char))
                            ((eq type-keyword :signed-8-bit-vector)
                             (typep val '(signed-byte 8)))
                            ((eq type-keyword :unsigned-8-bit-vector)
                             (typep val '(unsigned-byte 8)))
                            ((eq type-keyword :signed-16-bit-vector) 
                             (typep val '(signed-byte 16)))
                            ((eq type-keyword :unsigned-16-bit-vector)
                             (typep val '(unsigned-byte 16)))
                            ((eq type-keyword :bit-vector)
                             (typep val 'bit)))))
          (if typep val))))))

(defun x862-target-reg-for-aset (vreg type-keyword)
  (let* ((arch (backend-target-arch *target-backend*))
         (is-node (member type-keyword (arch::target-gvector-types arch)))
         (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch)))
         (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
         (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
         (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
         (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
         (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector)))
         (vreg-class (if (and vreg (not (eq vreg :push))) (hard-regspec-class vreg)))
         (vreg-mode (if (or (eql vreg-class hard-reg-class-gpr)
                            (eql vreg-class hard-reg-class-fpr))
                      (get-regspec-mode vreg)))
         (next-imm-target (available-imm-temp  *available-backend-imm-temps*))
         (next-fp-target (available-fp-temp *available-backend-fp-temps*))
         (acc (make-wired-lreg x8664::arg_z)))
    (cond ((or is-node
               (eq vreg :push)
               is-1-bit
               (eq type-keyword :simple-string)
               (eq type-keyword :fixnum-vector)
               (and (eql vreg-class hard-reg-class-gpr)
                    (eql vreg-mode hard-reg-class-gpr-mode-node)))
           acc)
          ;; If there's no vreg - if we're setting for effect only, and
          ;; not for value - we can target an unboxed register directly.
          ;; Usually.
          ((null vreg)
           (cond (is-64-bit
                  (if (eq type-keyword :double-float-vector)
                    (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-double)
                    (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s64 hard-reg-class-gpr-mode-u64))))
                 (is-32-bit
                  (if (eq type-keyword :single-float-vector)
                    (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-single)
                    (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s32 hard-reg-class-gpr-mode-u32))))
                 (is-16-bit
                  (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s16 hard-reg-class-gpr-mode-u16)))
                 (is-8-bit
                  (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s8 hard-reg-class-gpr-mode-u8)))
                 (t "Bug: can't determine operand size for ~s" type-keyword)))
          ;; Vreg is non-null.  We might be able to use it directly.
          (t
           (let* ((lreg (if vreg-mode
                          (make-unwired-lreg (lreg-value vreg)))))
             (if 
               (cond
                 (is-64-bit
                  (if (eq type-keyword :double-float-vector)
                    (and (eql vreg-class hard-reg-class-fpr)
                         (eql vreg-mode hard-reg-class-fpr-mode-double))
                      (if is-signed
                        (and (eql vreg-class hard-reg-class-gpr)
                                 (eql vreg-mode hard-reg-class-gpr-mode-s64))
                        (and (eql vreg-class hard-reg-class-gpr)
                                 (eql vreg-mode hard-reg-class-gpr-mode-u64)))))
                   (is-32-bit
                    (if (eq type-keyword :single-float-vector)
                      (and (eql vreg-class hard-reg-class-fpr)
                               (eql vreg-mode hard-reg-class-fpr-mode-single))
                      (if is-signed
                        (and (eql vreg-class hard-reg-class-gpr)
                                 (or (eql vreg-mode hard-reg-class-gpr-mode-s32)
                                     (eql vreg-mode hard-reg-class-gpr-mode-s64)))
                        (and (eql vreg-class hard-reg-class-gpr)
                                 (or (eql vreg-mode hard-reg-class-gpr-mode-u32)
                                     (eql vreg-mode hard-reg-class-gpr-mode-u64)
                                     (eql vreg-mode hard-reg-class-gpr-mode-s64))))))
                   (is-16-bit
                    (if is-signed
                      (and (eql vreg-class hard-reg-class-gpr)
                               (or (eql vreg-mode hard-reg-class-gpr-mode-s16)
                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
                                   (eql vreg-mode hard-reg-class-gpr-mode-s64)))
                      (and (eql vreg-class hard-reg-class-gpr)
                               (or (eql vreg-mode hard-reg-class-gpr-mode-u16)
                                   (eql vreg-mode hard-reg-class-gpr-mode-u32)
                                   (eql vreg-mode hard-reg-class-gpr-mode-u64)
                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
                                   (eql vreg-mode hard-reg-class-gpr-mode-s64)))))
                   (t
                    (if is-signed
                      (and (eql vreg-class hard-reg-class-gpr)
                               (or (eql vreg-mode hard-reg-class-gpr-mode-s8)
                                   (eql vreg-mode hard-reg-class-gpr-mode-s16)
                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
                                   (eql vreg-mode hard-reg-class-gpr-mode-s64)))
                      (and (eql vreg-class hard-reg-class-gpr)
                               (or (eql vreg-mode hard-reg-class-gpr-mode-u8)
                                   (eql vreg-mode hard-reg-class-gpr-mode-u16)
                                   (eql vreg-mode hard-reg-class-gpr-mode-u32)
                                   (eql vreg-mode hard-reg-class-gpr-mode-u64)
                                   (eql vreg-mode hard-reg-class-gpr-mode-s16)
                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
                                   (eql vreg-mode hard-reg-class-gpr-mode-s64))))))
               lreg
               acc))))))

(defun x862-unboxed-reg-for-aset (seg type-keyword result-reg safe constval)
  (with-x86-local-vinsn-macros (seg)
    (let* ((arch (backend-target-arch *target-backend*))
           (is-node (member type-keyword (arch::target-gvector-types arch)))
           (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
           (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
           (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
           (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
           (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector)))
           (result-is-node-gpr (and (eql (hard-regspec-class result-reg)
                                         hard-reg-class-gpr)
                                    (eql (get-regspec-mode result-reg)
                                         hard-reg-class-gpr-mode-node)))
           (next-imm-target (available-imm-temp *available-backend-imm-temps*))
           (next-fp-target (available-fp-temp *available-backend-fp-temps*)))
      (if (or is-node (not result-is-node-gpr))
        result-reg
        (cond (is-64-bit
               (if (eq type-keyword :double-float-vector)
                 (let* ((reg (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-double)))
                   (if safe
                     (! get-double? reg result-reg)
                     (! get-double reg result-reg))
                   reg)
                 (if is-signed
                   (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s64)))
                     (if (eq type-keyword :fixnum-vector)
                       (progn
                         (when safe
                           (! trap-unless-fixnum result-reg))
                         (! fixnum->signed-natural reg result-reg))
                       (! unbox-s64 reg result-reg))
                     reg)
                   (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u64)))
                     (! unbox-u64 reg result-reg)
                     reg))))
              (is-32-bit
               ;; Generally better to use a GPR for the :SINGLE-FLOAT-VECTOR
               ;; case here.
               (if is-signed             
                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s32)))
                   (if (eq type-keyword :fixnum-vector)
                     (progn
                       (when safe
                         (! trap-unless-fixnum result-reg))
                       (! fixnum->signed-natural reg result-reg))
                     (! unbox-s32 reg result-reg))
                   reg)
                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u32)))
                   (cond ((eq type-keyword :simple-string)
                          (if (characterp constval)
                            (x862-lri seg reg (char-code constval))
                            (! unbox-base-char reg result-reg)))
                         ((eq type-keyword :single-float-vector)
                          (if (typep constval 'single-float)
                            (x862-lri seg reg (single-float-bits constval))
                            (progn
                              (when safe
                                (! trap-unless-single-float result-reg))
                              (! single-float-bits reg result-reg))))
                         (t
                          (if (typep constval '(unsigned-byte 32))
                            (x862-lri seg reg constval)
                            (if *x862-reckless*
                              (! %unbox-u32 reg result-reg)
                              (! unbox-u32 reg result-reg)))))
                   reg)))
              (is-16-bit
               (if is-signed
                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s16)))
                   (if (typep constval '(signed-byte 16))
                     (x862-lri seg reg constval)
                     (if *x862-reckless*
                       (! %unbox-s16 reg result-reg)
                       (! unbox-s16 reg result-reg)))
                   reg)
                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u16)))
                   (if (typep constval '(unsigned-byte 16))
                     (x862-lri seg reg constval)
                     (if *x862-reckless*
                       (! %unbox-u16 reg result-reg)
                       (! unbox-u16 reg result-reg)))
                   reg)))
              (is-8-bit
               (if is-signed
                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s8)))
                   (if (typep constval '(signed-byte 8))
                     (x862-lri seg reg constval)
                     (if *x862-reckless*
                       (! %unbox-s8 reg result-reg)
                       (! unbox-s8 reg result-reg)))
                   reg)
                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u8)))
                   (if (typep constval '(unsigned-byte 8))
                     (x862-lri seg reg constval)
                     (if *x862-reckless*
                       (! %unbox-u8 reg result-reg)
                       (! unbox-u8 reg result-reg)))
                   reg)))
              (t
                 (let* ((reg result-reg))
                   (unless (typep constval 'bit)
                     (when safe
                       (! trap-unless-bit reg )))
                   reg)))))))

(defun x862-vset1 (seg vreg xfer type-keyword src unscaled-idx index-known-fixnum val-reg unboxed-val-reg constval node-value-needs-memoization)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (let* ((arch (backend-target-arch *target-backend*))
           (is-node (member type-keyword (arch::target-gvector-types arch)))
           (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch)))
           (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
           (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
           (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
           (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
           (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector))))
      (cond ((and is-node node-value-needs-memoization)
             (unless (and (eql (hard-regspec-value src) x8664::arg_x)
                          (eql (hard-regspec-value unscaled-idx) x8664::arg_y)
                          (eql (hard-regspec-value val-reg) x8664::arg_z))
               (nx-error "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg)))
             (! call-subprim-3 val-reg (subprim-name->offset '.SPgvset) src unscaled-idx val-reg))
            (is-node
             (if (and index-known-fixnum (<= index-known-fixnum
                                             (target-word-size-case
                                              (32 (arch::target-max-32-bit-constant-index arch))
                                              (64 (arch::target-max-64-bit-constant-index arch)))))
               (if (typep constval '(signed-byte 32))
                 (! misc-set-immediate-c-node constval src index-known-fixnum)
                 (! misc-set-c-node val-reg src index-known-fixnum))
               (progn
                 (if index-known-fixnum
                   (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum *x862-target-node-shift*))))
                 (if (typep constval '(signed-byte 32))
                   (! misc-set-immediate-node constval src unscaled-idx)
                   (! misc-set-node val-reg src unscaled-idx)))))
            (t
             (with-imm-target (unboxed-val-reg) scaled-idx
               (cond
                 (is-64-bit
                  (if (and index-known-fixnum
                           (<= index-known-fixnum
                               (arch::target-max-64-bit-constant-index arch)))
                    (if (eq type-keyword :double-float-vector)
                      (! misc-set-c-double-float unboxed-val-reg src index-known-fixnum)
                      (if is-signed
                        (! misc-set-c-s64 unboxed-val-reg src index-known-fixnum)
                        (! misc-set-c-u64 unboxed-val-reg src index-known-fixnum)))
                    (progn
                      (if index-known-fixnum
                        (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3))))
                      (if (eq type-keyword :double-float-vector)
                        (! misc-set-double-float unboxed-val-reg src unscaled-idx)
                        (if is-signed
                          (! misc-set-s64 unboxed-val-reg src unscaled-idx)
                          (! misc-set-u64 unboxed-val-reg src unscaled-idx))))))
                 (is-32-bit
                  (if (and index-known-fixnum
                           (<= index-known-fixnum
                               (arch::target-max-32-bit-constant-index arch)))
                    (if (eq type-keyword :single-float-vector)
                      (if (eq (hard-regspec-class unboxed-val-reg)
                              hard-reg-class-fpr)
                        (! misc-set-c-single-float unboxed-val-reg src index-known-fixnum)
                        (! misc-set-c-u32 unboxed-val-reg src index-known-fixnum))
                      (if is-signed
                        (! misc-set-c-s32 unboxed-val-reg src index-known-fixnum)
                        (! misc-set-c-u32 unboxed-val-reg src index-known-fixnum)))
                    (progn
                      (if index-known-fixnum
                        (x862-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
                        (! scale-32bit-misc-index scaled-idx unscaled-idx))
                      (if (and (eq type-keyword :single-float-vector)
                               (eql (hard-regspec-class unboxed-val-reg)
                                    hard-reg-class-fpr))
                        (! misc-set-single-float unboxed-val-reg src scaled-idx)
                        (if is-signed
                          (! misc-set-s32 unboxed-val-reg src scaled-idx)
                          (! misc-set-u32 unboxed-val-reg src scaled-idx))))))
                 (is-16-bit
                  (if (and index-known-fixnum
                           (<= index-known-fixnum
                               (arch::target-max-16-bit-constant-index arch)))
                    (if is-signed
                      (! misc-set-c-s16 unboxed-val-reg src index-known-fixnum)
                      (! misc-set-c-u16 unboxed-val-reg src index-known-fixnum))
                    (progn
                      (if index-known-fixnum
                        (x862-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1)))
                        (! scale-16bit-misc-index scaled-idx unscaled-idx))
                      (if is-signed
                        (! misc-set-s16 unboxed-val-reg src scaled-idx)
                        (! misc-set-u16 unboxed-val-reg src scaled-idx)))))
                 (is-8-bit
                  (if (and index-known-fixnum
                           (<= index-known-fixnum
                               (arch::target-max-8-bit-constant-index arch)))
                    (if is-signed
                      (! misc-set-c-s8 unboxed-val-reg src index-known-fixnum)
                      (! misc-set-c-u8  unboxed-val-reg src index-known-fixnum))
                    (progn
                      (if index-known-fixnum
                        (x862-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) index-known-fixnum))
                        (! scale-8bit-misc-index scaled-idx unscaled-idx))
                      (if is-signed
                        (! misc-set-s8 unboxed-val-reg src scaled-idx)
                        (! misc-set-u8 unboxed-val-reg src scaled-idx)))))
                 (is-1-bit
                  (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch)))
                    (if constval
                      (if (zerop constval)
                        (! set-constant-bit-to-zero src index-known-fixnum)
                        (! set-constant-bit-to-one src index-known-fixnum))
                      (progn
                        (! set-constant-bit-to-variable-value src index-known-fixnum val-reg)))
                    (with-imm-temps () (word-index bit-number)
                      (if index-known-fixnum
                        (progn
                          (x862-lri seg word-index (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum -6)))
                          (x862-lri seg bit-number (logand index-known-fixnum #x63)))
                        (! word-index-and-bitnum-from-index word-index bit-number unscaled-idx))
                      (if constval
                        (if (zerop constval)
                          (! set-variable-bit-to-zero src word-index bit-number)
                          (! set-variable-bit-to-one src word-index bit-number))
                        (progn
                          (! set-variable-bit-to-variable-value src word-index bit-number val-reg))))))))))
      (when (and vreg val-reg) (<- val-reg))
      (^))))
          
          

(defun x862-vset (seg vreg xfer type-keyword vector index value safe)
  (with-x86-local-vinsn-macros (seg)
    (let* ((arch (backend-target-arch *target-backend*))
           (is-node (member type-keyword (arch::target-gvector-types arch)))
           (constval (x862-constant-value-ok-for-type-keyword type-keyword value))
           (needs-memoization (and is-node (x862-acode-needs-memoization value)))
           (index-known-fixnum (acode-fixnum-form-p index)))
      (let* ((src ($ x8664::arg_x))
             (unscaled-idx ($ x8664::arg_y))
             (result-reg ($ x8664::arg_z)))
        (cond (needs-memoization
               (x862-three-targeted-reg-forms seg
                                              vector src
                                              index unscaled-idx
                                              value result-reg))
              (t
               (setq result-reg (x862-target-reg-for-aset vreg type-keyword))
               (x862-three-targeted-reg-forms seg
                                              vector src
                                              index unscaled-idx
                                              value result-reg)))
        (when safe
          (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)
                 (value (if (eql (hard-regspec-class result-reg)
                                 hard-reg-class-gpr)
                          (hard-regspec-value result-reg))))
            (when (and value (logbitp value *available-backend-imm-temps*))
              (setq *available-backend-imm-temps* (bitclr value *available-backend-imm-temps*)))
            (if (typep safe 'fixnum)
              (! trap-unless-typecode= src safe))
            (unless index-known-fixnum
              (! trap-unless-fixnum unscaled-idx))
            (! check-misc-bound unscaled-idx src)))
        (x862-vset1 seg vreg xfer type-keyword src unscaled-idx index-known-fixnum result-reg (x862-unboxed-reg-for-aset seg type-keyword result-reg safe constval) constval needs-memoization)))))



(defun x862-tail-call-alias (immref sym &optional arglist)
  (let ((alias (cdr (assq sym *x862-tail-call-aliases*))))
    (if (and alias (or (null arglist) (eq (+ (length (car arglist)) (length (cadr arglist))) (cdr alias))))
      (make-acode (%nx1-operator immediate) (car alias))
      immref)))

;;; If BODY is essentially an APPLY involving an &rest arg, try to avoid
;;; consing it.
(defun x862-eliminate-&rest (body rest key-p auxen rest-values)
  (when (and rest (not key-p) (not (cadr auxen)) rest-values)
    (when (eq (logand (the fixnum (nx-var-bits rest))
                      (logior $vsetqmask (ash -1 $vbitspecial)
                              (ash 1 $vbitclosed) (ash 1 $vbitsetq) (ash 1 $vbitcloseddownward)))
              0)               ; Nothing but simple references
      (do* ()
           ((not (acode-p body)))
        (let* ((op (acode-operator body)))
          (if (or (eq op (%nx1-operator lexical-function-call))
                  (eq op (%nx1-operator call)))
            (destructuring-bind (fn-form (stack-args reg-args) &optional spread-p) (%cdr body)
               (unless (and (eq spread-p t)
                           (eq (x862-lexical-reference-p (%car reg-args)) rest))
                (return nil))
              (flet ((independent-of-all-values (form)        
                       (setq form (acode-unwrapped-form form))
                       (or (x86-constant-form-p form)
                           (let* ((lexref (x862-lexical-reference-p form)))
                             (and lexref 
                                  (neq lexref rest)
                                  (dolist (val rest-values t)
                                    (unless (x862-var-not-set-by-form-p lexref val)
                                      (return))))))))
                (unless (or (eq op (%nx1-operator lexical-function-call))
                            (independent-of-all-values fn-form))
                  (return nil))
                (if (dolist (s stack-args t)
                          (unless (independent-of-all-values s)
                            (return nil)))
                  (let* ((arglist (append stack-args rest-values)))
                    (return
                     (make-acode op 
                                 fn-form 
                                 (if (<= (length arglist) *x862-target-num-arg-regs*)
                                   (list nil (reverse arglist))
                                   (list (butlast arglist *x862-target-num-arg-regs*)
                                         (reverse (last arglist *x862-target-num-arg-regs*))))
                                 nil)))
                  (return nil))))
            (if (eq op (%nx1-operator local-block))
              (setq body (%cadr body))
              (if (and (eq op (%nx1-operator if))
                       (eq (x862-lexical-reference-p (%cadr body)) rest))
                (setq body (%caddr body))
                (return nil)))))))))

(defun x862-call-fn (seg vreg xfer fn arglist spread-p)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (when spread-p
      (destructuring-bind (stack-args reg-args) arglist
        (when (and (null (cdr reg-args))
                   (nx-null (acode-unwrapped-form (car reg-args))))
          (setq spread-p nil)
          (let* ((nargs (length stack-args)))
            (declare (fixnum nargs))
            (if (<= nargs *x862-target-num-arg-regs*)
              (setq arglist (list nil (reverse stack-args)))
              (setq arglist (list (butlast stack-args *x862-target-num-arg-regs*) (reverse (last stack-args *x862-target-num-arg-regs*)))))))))
    (let* ((lexref (x862-lexical-reference-p fn))
           (simple-case (or (fixnump fn)
                            (typep fn 'lreg)
                            (x862-immediate-function-p fn)
                            (and 
                             lexref
                             (not spread-p)
                             (flet ((all-simple (args)
                                      (dolist (arg args t)
                                        (when (and arg (not (x862-var-not-set-by-form-p lexref arg)))
                                          (return)))))
                               (and (all-simple (car arglist))
                                    (all-simple (cadr arglist))
                                    (setq fn (var-ea lexref)))))))
           (cstack *x862-cstack*)
           (top *x862-top-vstack-lcell*)
           (vstack *x862-vstack*))
      (setq xfer (or xfer 0))
      (when (and (eq xfer $backend-return)
                 (eq 0 *x862-undo-count*)
                 (acode-p fn)
                 (eq (acode-operator fn) (%nx1-operator immediate))
                 (symbolp (cadr fn)))
        (setq fn (x862-tail-call-alias fn (%cadr fn) arglist)))
      
      (if (and (eq xfer $backend-return) (not (x862-tailcallok xfer)))
        (progn
          (x862-call-fn seg vreg $backend-mvpass fn arglist spread-p)
          (x862-set-vstack (%i+ (if simple-case 0 *x862-target-node-size*) vstack))
          (setq  *x862-cstack* cstack)
          (let ((*x862-returning-values* t)) (x862-do-return seg)))
        (let* ((mv-p (x862-mv-p xfer))
               (mv-return-label (if (and mv-p
                                         (not (x862-tailcallok xfer)))
                                  (backend-get-next-label))))
          (unless simple-case
            (x862-vpush-register seg (x862-one-untargeted-reg-form seg fn x8664::arg_z))
            (setq fn (x862-vloc-ea vstack)))
          (x862-invoke-fn seg fn (x862-arglist seg arglist mv-return-label) spread-p xfer mv-return-label)
          (if (and (logbitp $backend-mvpass-bit xfer)
                   (not simple-case))
            (progn
              (! save-values)
              (! vstack-discard 1)
              (x862-set-nargs seg 0)
              (! recover-values))
            (unless (or mv-p simple-case)
              (! vstack-discard 1)))
          (x862-set-vstack vstack)
          (setq *x862-top-vstack-lcell* top)
          (setq *x862-cstack* cstack)
          (when (or (logbitp $backend-mvpass-bit xfer) (not mv-p))
            (<- x8664::arg_z)
            (x862-branch seg (logand (lognot $backend-mvpass-mask) xfer)))))
      nil)))

(defun x862-restore-full-lisp-context (seg)
  (with-x86-local-vinsn-macros (seg)
    (! restore-full-lisp-context)))

(defun x862-emit-aligned-label (seg labelnum)
  (with-x86-local-vinsn-macros (seg)
    (! emit-aligned-label (aref *backend-labels* labelnum))
    (@ labelnum)
    (! recover-fn-from-rip)))

  
(defun x862-call-symbol (seg jump-p)
  (with-x86-local-vinsn-macros (seg)
    (if jump-p
      (! jump-known-symbol)
      (! call-known-symbol x8664::arg_z))))

;;; Nargs = nil -> multiple-value case.
(defun x862-invoke-fn (seg fn nargs spread-p xfer &optional mvpass-label)
  (with-x86-local-vinsn-macros (seg)
    (let* ((f-op (acode-unwrapped-form fn))
           (immp (and (consp f-op)
                      (eq (%car f-op) (%nx1-operator immediate))))
           (symp (and immp (symbolp (%cadr f-op))))
           (label-p (and (fixnump fn) 
                         (locally (declare (fixnum fn))
                           (and (= fn -2) (- fn)))))
           (tail-p (eq xfer $backend-return))
           (func (if (consp f-op) (%cadr f-op)))
           (a-reg nil)
           (lfunp (and (acode-p f-op) 
                       (eq (acode-operator f-op) (%nx1-operator simple-function))))
           (expression-p (or (typep fn 'lreg) (and (fixnump fn) (not label-p))))
           (callable (or symp lfunp label-p))
           (destreg (if symp ($ x8664::fname) (unless label-p ($ x8664::temp0))))
           (alternate-tail-call
            (and tail-p label-p *x862-tail-label* (eql nargs *x862-tail-nargs*) (not spread-p))))
      (when expression-p
        ;;Have to do this before spread args, since might be vsp-relative.
        (if nargs
          (x862-do-lexical-reference seg destreg fn)
          (x862-copy-register seg destreg fn)))
      (if (or symp lfunp)
        (setq func (if symp
                     (x862-symbol-entry-locative func)
                     (x862-afunc-lfun-ref func))
              a-reg (x862-register-constant-p func)))
      (when tail-p
        #-no-compiler-bugs
        (unless (or immp symp lfunp (typep fn 'lreg) (fixnump fn)) (compiler-bug "Well, well, well.  How could this have happened ?"))
        (when a-reg
          (x862-copy-register seg destreg a-reg))
        (unless spread-p
          (unless alternate-tail-call
            (x862-restore-nvrs seg *x862-register-restore-ea* *x862-register-restore-count* (and nargs (<= nargs *x862-target-num-arg-regs*))))))
      (if spread-p
        (progn
          (x862-set-nargs seg (%i- nargs 1))
                                        ; .SPspread-lexpr-z & .SPspreadargz preserve temp1
          (if (eq spread-p 0)
            (! spread-lexpr)
            (! spread-list))
          (when (and tail-p *x862-register-restore-count*)
            (x862-restore-nvrs seg *x862-register-restore-ea* *x862-register-restore-count* nil)))
        (if nargs
          (unless alternate-tail-call (x862-set-nargs seg nargs))
          (! pop-argument-registers)))
      (if callable
        (if (not tail-p)
          (if (x862-mvpass-p xfer)
            (let* ((call-reg (if symp ($ x8664::fname) ($ x8664::temp0))))
              (unless mvpass-label (compiler-bug "no label for mvpass"))
              (if label-p
                (x862-copy-register seg call-reg ($ x8664::fn))
                (if a-reg
                  (x862-copy-register seg call-reg  a-reg)
                  (x862-store-immediate seg func call-reg)))
              (if symp
                (! pass-multiple-values-symbol)
                (! pass-multiple-values))
              (when mvpass-label
                (@= mvpass-label)))
            (progn 
              (if label-p
                (progn
                  (! call-label (aref *backend-labels* 2)))
                (progn
                  (if a-reg
                    (x862-copy-register seg destreg a-reg)
                    (x862-store-immediate seg func destreg))
                  (if symp
                    (x862-call-symbol seg nil)
                    (! call-known-function))))))
          (if alternate-tail-call
            (progn
              (x862-unwind-stack seg xfer 0 0 *x862-tail-vsp*)
              (! jump (aref *backend-labels* *x862-tail-label*)))
            (progn
              (x862-unwind-stack seg xfer 0 0 #x7fffff)
              (if (and (not spread-p) nargs (%i<= nargs *x862-target-num-arg-regs*))
                (progn
                  (unless (or label-p a-reg) (x862-store-immediate seg func destreg))
                  (x862-restore-full-lisp-context seg)
                  (if label-p
                    (! jump (aref *backend-labels* 1))
                    (progn
                      (if symp
                        (x862-call-symbol seg t)
                        (! jump-known-function)))))
                (progn
                  (unless (or label-p a-reg) (x862-store-immediate seg func destreg))
                  (when label-p
                    (x862-copy-register seg x8664::temp0 x8664::fn))

                  (cond ((or spread-p (null nargs))
                         (if symp
                           (! tail-call-sym-gen)
                           (! tail-call-fn-gen)))
                        ((%i> nargs *x862-target-num-arg-regs*)
                         (if symp
                           (! tail-call-sym-slide)
                           (! tail-call-fn-slide)))
                        (t
                         (if symp
                           (! tail-call-sym-vsp)
                           (! tail-call-fn-vsp)))))))))
        ;; The general (funcall) case: we don't know (at compile-time)
        ;; for sure whether we've got a symbol or a (local, constant)
        ;; function.
        (progn
          (unless (or (fixnump fn) (typep fn 'lreg))
            (x862-one-targeted-reg-form seg fn destreg))
          (if (not tail-p)
            (if (x862-mvpass-p xfer)
              (progn (! pass-multiple-values)
                     (when mvpass-label
                       (@= mvpass-label)))
              (! funcall))                  
            (cond ((or (null nargs) spread-p)
                   (! tail-funcall-gen))
                  ((%i> nargs *x862-target-num-arg-regs*)
                   (! tail-funcall-slide))
                  (t
                   (! restore-full-lisp-context)
                   (! tail-funcall)))))))
    nil))

(defun x862-seq-fbind (seg vreg xfer vars afuncs body p2decls)
  (let* ((old-stack (x862-encode-stack))
         (copy afuncs)
         (func nil))
    (with-x86-p2-declarations p2decls 
      (dolist (var vars) 
        (when (neq 0 (afunc-fn-refcount (setq func (pop afuncs))))
          (x862-seq-bind-var seg var (nx1-afunc-ref func))))
      (x862-undo-body seg vreg xfer body old-stack)
      (dolist (var vars)
        (when (neq 0 (afunc-fn-refcount (setq func (pop copy))))
          (x862-close-var seg var))))))

(defun x862-make-closure (seg afunc downward-p)
  (with-x86-local-vinsn-macros (seg)
    (flet ((var-to-reg (var target)
             (let* ((ea (var-ea (var-bits var))))
               (if ea
                 (x862-addrspec-to-reg seg (x862-ea-open ea) target)
                 (! load-nil target))
               target))
           (set-some-cells (dest cellno c0 c1 c2 c3)
             (declare (fixnum cellno))
             (! misc-set-c-node c0 dest cellno)
             (incf cellno)
             (when c1
               (! misc-set-c-node c1 dest cellno)
               (incf cellno)
               (when c2
                 (! misc-set-c-node c2 dest cellno)
                 (incf cellno)
                 (when c3
                   (! misc-set-c-node c3 dest cellno)
                   (incf cellno))))
             cellno))
      (let* ((inherited-vars (afunc-inherited-vars afunc))
             (arch (backend-target-arch *target-backend*))
             (dest ($ x8664::arg_z))
             (vsize (+ (length inherited-vars) 
                       5                ; %closure-code%, afunc
                       1)))             ; lfun-bits
        (declare (list inherited-vars))
        (let* ((cell 4))
          (declare (fixnum cell))
          (if downward-p
            (progn
              (! make-fixed-stack-gvector
                 dest
                 (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch))
                 (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function)))
              (x862-open-undo $undostkblk))
            (progn
              (x862-lri seg
                        x8664::imm0
                        (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function)))
              (x862-lri seg x8664::imm1 (- (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch)) (target-arch-case  (:x8664 x8664::fulltag-misc))))
              (! %allocate-uvector dest)))
          (! init-nclosure x8664::arg_z)
          (x862-store-immediate seg (x862-afunc-lfun-ref afunc) x8664::ra0)
          (with-node-temps (x8664::arg_z) (t0 t1 t2 t3)
            (do* ((func x8664::ra0 nil))
                 ((null inherited-vars))
              (let* ((t0r (or func (if inherited-vars (var-to-reg (pop inherited-vars) t0))))
                     (t1r (if inherited-vars (var-to-reg (pop inherited-vars) t1)))
                     (t2r (if inherited-vars (var-to-reg (pop inherited-vars) t2)))
                     (t3r (if inherited-vars (var-to-reg (pop inherited-vars) t3))))
                (setq cell (set-some-cells dest cell t0r t1r t2r t3r)))))
          (x862-lri seg x8664::arg_y (ash (logior (ash 1 $lfbits-noname-bit) (ash 1 $lfbits-trampoline-bit)) *x862-target-fixnum-shift*))
          (! misc-set-c-node x8664::arg_y dest cell))
        (! finalize-closure dest)
        dest))))
        
(defun x862-symbol-entry-locative (sym)
  (setq sym (require-type sym 'symbol))
  (when (eq sym '%call-next-method-with-args)
    (setf (afunc-bits *x862-cur-afunc*)
          (%ilogior (%ilsl $fbitnextmethargsp 1) (afunc-bits *x862-cur-afunc*))))
  (or (assq sym *x862-fcells*)
      (let ((new (list sym)))
        (push new *x862-fcells*)
        new)))

(defun x862-symbol-value-cell (sym)
  (setq sym (require-type sym 'symbol))
  (or (assq sym *x862-vcells*)
      (let ((new (list sym)))
        (push new *x862-vcells*)
        (ensure-binding-index sym)
        new)))


(defun x862-symbol-locative-p (imm)
  (and (consp imm)
       (or (memq imm *x862-vcells*)
           (memq imm *x862-fcells*))))




(defun x862-immediate-function-p (f)
  (setq f (acode-unwrapped-form f))
  (and (acode-p f)
       (or (eq (%car f) (%nx1-operator immediate))
           (eq (%car f) (%nx1-operator simple-function)))))

(defun x86-constant-form-p (form)
  (setq form (nx-untyped-form form))
  (if form
    (or (nx-null form)
        (nx-t form)
        (and (consp form)
             (or (eq (acode-operator form) (%nx1-operator immediate))
                 (eq (acode-operator form) (%nx1-operator fixnum))
                 (eq (acode-operator form) (%nx1-operator simple-function)))))))


  
(defun x862-long-constant-p (form)
  (setq form (acode-unwrapped-form form))
  (or (acode-fixnum-form-p form)
      (and (acode-p form)
           (eq (acode-operator form) (%nx1-operator immediate))
           (setq form (%cadr form))
           (if (integerp form) 
             form))))


(defun x86-side-effect-free-form-p (form)
  (when (consp (setq form (acode-unwrapped-form form)))
    (or (x86-constant-form-p form)
        ;(eq (acode-operator form) (%nx1-operator bound-special-ref))
        (if (eq (acode-operator form) (%nx1-operator lexical-reference))
          (not (%ilogbitp $vbitsetq (nx-var-bits (%cadr form))))))))

(defun x862-formlist (seg stkargs &optional revregargs)
  (with-x86-local-vinsn-macros (seg)  
    (let* ((nregs (length revregargs))
           (n nregs))
      (declare (fixnum n))
      (dolist (arg stkargs)
        (let* ((pushform (x862-acode-operator-supports-push arg)))
          (if pushform
            (progn
              (x862-form seg :push nil pushform)
              (x862-new-vstack-lcell :outgoing-argument *x862-target-lcell-size* 0 nil)
              (x862-adjust-vstack *x862-target-node-size*))
              
            (let* ((reg (x862-one-untargeted-reg-form seg arg x8664::arg_z)))
              (x862-vpush-register-arg seg reg)))
          (incf n)))
      (when revregargs
        (let* ((zform (%car revregargs))
               (yform (%cadr revregargs))
               (xform (%caddr revregargs)))
          (if (eq 3 nregs)
            (x862-three-targeted-reg-forms seg xform ($ x8664::arg_x) yform ($ x8664::arg_y) zform ($ x8664::arg_z))
            (if (eq 2 nregs)
              (x862-two-targeted-reg-forms seg yform ($ x8664::arg_y) zform ($ x8664::arg_z))
              (x862-one-targeted-reg-form seg zform ($ x8664::arg_z))))))
      n)))

(defun x862-arglist (seg args &optional mv-label)
  (with-x86-local-vinsn-macros (seg)
    (when mv-label
      (x862-vpush-label seg (aref *backend-labels* mv-label)))
    (when (car args)
      (! reserve-outgoing-frame)
      (x862-new-vstack-lcell :reserverd *x862-target-lcell-size* 0 nil)
      (x862-new-vstack-lcell :reserverd *x862-target-lcell-size* 0 nil)
      (setq *x862-vstack* (+  *x862-vstack* (* 2 *x862-target-node-size*))))
    (x862-formlist seg (car args) (cadr args))))




;;; treat form as a 32-bit immediate value and load it into immreg.
;;; This is the "lenient" version of 32-bit-ness; OSTYPEs and chars
;;; count, and we don't care about the integer's sign.

(defun x862-unboxed-integer-arg-to-reg (seg form immreg &optional ffi-arg-type)
  (let* ((mode (ecase ffi-arg-type
                 ((nil) :natural)
                 (:signed-byte :s8)
                 (:unsigned-byte :u8)
                 (:signed-halfword :s16)
                 (:unsigned-halfword :u16)
                 (:signed-fullword :s32)
                 (:unsigned-fullword :u32)
                 (:unsigned-doubleword :u64)
                 (:signed-doubleword :s64)))
         (modeval (gpr-mode-name-value mode)))
    (with-x86-local-vinsn-macros (seg)
      (let* ((value (x862-long-constant-p form)))
        (if value
          (progn
            (unless (typep immreg 'lreg)
              (setq immreg (make-unwired-lreg immreg :mode modeval)))
            (x862-lri seg immreg value)
            immreg)
          (progn 
            (x862-one-targeted-reg-form seg form (make-wired-lreg x8664::imm0 :mode modeval))))))))


(defun x862-macptr-arg-to-reg (seg form address-reg)  
  (x862-one-targeted-reg-form seg
                              form 
                              address-reg))


(defun x862-one-lreg-form (seg form lreg)
  (let ((is-float (= (hard-regspec-class lreg) hard-reg-class-fpr)))
    (if is-float
      (x862-form-float seg lreg nil form)
      (x862-form seg lreg nil form))
    lreg))

(defun x862-one-targeted-reg-form (seg form reg)
  (x862-one-lreg-form seg form reg))

(defun x862-one-untargeted-lreg-form (seg form reg)
  (x862-one-lreg-form seg form (if (typep reg 'lreg) reg (make-unwired-lreg reg))))

(defun x862-one-untargeted-reg-form (seg form suggested)
  (with-x86-local-vinsn-macros (seg)
    (let* ((gpr-p (= (hard-regspec-class suggested) hard-reg-class-gpr))
           (node-p (if gpr-p (= (get-regspec-mode suggested) hard-reg-class-gpr-mode-node))))
      (if node-p
        (let* ((ref (x862-lexical-reference-ea form))
               (reg (backend-ea-physical-reg ref hard-reg-class-gpr)))
          (if reg
            ref
            (if (nx-null form)
              (progn
                (! load-nil suggested)
                suggested)
              (if (and (acode-p form) 
                       (eq (acode-operator form) (%nx1-operator immediate)) 
                       (setq reg (x862-register-constant-p (cadr form))))
                reg
                (x862-one-untargeted-lreg-form seg form suggested)))))
        (x862-one-untargeted-lreg-form seg form suggested)))))
             

(defun x862-push-register (seg areg)
  (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr))
         (a-single (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-single)))
         (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node)))
         vinsn)
    (with-x86-local-vinsn-macros (seg)
      (if a-node
        (setq vinsn (x862-vpush-register seg areg :node-temp))
        (if a-single
          (progn
            (setq vinsn (! vpush-single-float areg))
            (x862-new-vstack-lcell :single-float *x862-target-lcell-size* 0 nil)
            (x862-adjust-vstack *x862-target-node-size*))
          (progn
            (setq vinsn
                  (if a-float
                    (! temp-push-double-float areg)
                    (! temp-push-unboxed-word areg)))
            (setq *x862-cstack* (+ *x862-cstack* 16)))))
      vinsn)))

(defun x862-pop-register (seg areg)
  (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr))
         (a-single (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-single)))
         (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node)))
         vinsn)
    (with-x86-local-vinsn-macros (seg)
      (if a-node
        (setq vinsn (x862-vpop-register seg areg))
        (if a-single
          (progn
            (setq vinsn (! vpop-single-float areg))
            (setq *x862-top-vstack-lcell* (lcell-parent *x862-top-vstack-lcell*))
            (x862-adjust-vstack (- *x862-target-node-size*)))
          (progn
            (setq vinsn
                  (if a-float
                    (! temp-pop-double-float areg)
                    (! temp-pop-unboxed-word areg)))
            (setq *x862-cstack* (- *x862-cstack* 16)))))
      vinsn)))

(defun x862-acc-reg-for (reg)
  (with-x86-local-vinsn-macros (seg)
    (let* ((class (hard-regspec-class reg))
           (mode (get-regspec-mode reg)))
      (declare (fixnum class mode))
      (cond ((= class hard-reg-class-fpr)
             (make-wired-lreg x8664::fp1 :class class :mode mode))
            ((= class hard-reg-class-gpr)
             (if (= mode hard-reg-class-gpr-mode-node)
               ($ x8664::arg_z)
               (make-wired-lreg x8664::imm0 :mode mode)))
            (t (compiler-bug "Unknown register class for reg ~s" reg))))))

;;; The compiler often generates superfluous pushes & pops.  Try to
;;; eliminate them.
(defun x862-elide-pushes (seg push-vinsn pop-vinsn)
  (with-x86-local-vinsn-macros (seg)
    (let* ((pushed-reg (svref (vinsn-variable-parts push-vinsn) 0))
           (popped-reg (svref (vinsn-variable-parts pop-vinsn) 0))
           (same-reg (eq (hard-regspec-value pushed-reg)
                         (hard-regspec-value popped-reg)))
           (csp-p (vinsn-attribute-p push-vinsn :csp)))
      (when csp-p                       ; vsp case is harder.
        (let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p
                                   push-vinsn pop-vinsn pushed-reg))
               (popped-reg-is-set (if same-reg
                                    pushed-reg-is-set
                                    (vinsn-sequence-sets-reg-p
                                     push-vinsn pop-vinsn popped-reg))))
          (unless (and pushed-reg-is-set popped-reg-is-set)
            (unless same-reg
              (let* ((copy (if (eq (hard-regspec-class pushed-reg)
                                   hard-reg-class-fpr)
                             (if (= (get-regspec-mode pushed-reg)
                                    hard-reg-class-fpr-mode-double)
                               (! copy-double-float popped-reg pushed-reg)
                               (! copy-single-float popped-reg pushed-reg))
                             (! copy-gpr popped-reg pushed-reg))))
                (remove-dll-node copy)
                (if pushed-reg-is-set
                  (insert-dll-node-after copy push-vinsn)
                  (insert-dll-node-before copy push-vinsn))))
            (elide-vinsn push-vinsn)
            (elide-vinsn pop-vinsn)))))))
                
        
;;; we never leave the first form pushed (the 68K compiler had some subprims that
;;; would vpop the first argument out of line.)
(defun x862-two-targeted-reg-forms (seg aform areg bform breg)
  (unless (typep areg 'lreg)
    (warn "~s is not an lreg (1/2)" areg))
  (unless (typep breg 'lreg)
    (warn "~s is not an lreg (2/2)" breg))
  (let* ((avar (x862-lexical-reference-p aform))
         (atriv (x862-trivial-p bform))
         (aconst (and (not atriv) (or (x86-side-effect-free-form-p aform)
                                      (if avar (x862-var-not-set-by-form-p avar bform)))))
         apushed)
    (progn
      (unless aconst
        (if atriv
          (x862-one-targeted-reg-form seg aform areg)
          (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg))))))
      (x862-one-targeted-reg-form seg bform breg)
      (if aconst
        (x862-one-targeted-reg-form seg aform areg)
        (if apushed
          (x862-elide-pushes seg apushed (x862-pop-register seg areg)))))
    (values areg breg)))


(defun x862-two-untargeted-reg-forms (seg aform areg bform breg)
  (with-x86-local-vinsn-macros (seg)
    (let* ((avar (x862-lexical-reference-p aform))
           (adest areg)
           (bdest breg)
           (atriv (x862-trivial-p bform))
           (aconst (and (not atriv) (or (x86-side-effect-free-form-p aform)
                                        (if avar (x862-var-not-set-by-form-p avar bform)))))
           (apushed (not (or atriv aconst))))
      (progn
        (unless aconst
          (if atriv
            (setq adest (x862-one-untargeted-reg-form seg aform areg))
            (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg))))))
        (setq bdest (x862-one-untargeted-reg-form seg bform breg))
        (if aconst
          (setq adest (x862-one-untargeted-reg-form seg aform areg))
          (if apushed
            (x862-elide-pushes seg apushed (x862-pop-register seg areg)))))
      (values adest bdest))))


(defun x862-three-targeted-reg-forms (seg aform areg bform breg cform creg)
  (unless (typep areg 'lreg)
    (warn "~s is not an lreg (1/3)" areg))
  (unless (typep breg 'lreg)
    (warn "~s is not an lreg (2/3)" breg))
  (unless (typep creg 'lreg)
    (warn "~s is not an lreg (3/3)" creg))
  (let* ((atriv (or (null aform) 
                    (and (x862-trivial-p bform)
                         (x862-trivial-p cform))))
         (btriv (or (null bform)
                    (x862-trivial-p cform)))
         (aconst (and (not atriv) 
                      (or (x86-side-effect-free-form-p aform)
                          (let ((avar (x862-lexical-reference-p aform)))
                            (and avar 
                                 (x862-var-not-set-by-form-p avar bform)
                                 (x862-var-not-set-by-form-p avar cform))))))
         (bconst (and (not btriv)
                      (or
                       (x86-side-effect-free-form-p bform)
                       (let ((bvar (x862-lexical-reference-p bform)))
                         (and bvar (x862-var-not-set-by-form-p bvar cform))))))
         (apushed nil)
         (bpushed nil))
    (if (and aform (not aconst))
      (if atriv
        (x862-one-targeted-reg-form seg aform areg)
        (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg))))))
    (if (and bform (not bconst))
      (if btriv
        (x862-one-targeted-reg-form seg bform breg)
        (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg))))))
    (x862-one-targeted-reg-form seg cform creg)
    (unless btriv 
      (if bconst
        (x862-one-targeted-reg-form seg bform breg)
        (x862-elide-pushes seg bpushed (x862-pop-register seg breg))))
    (unless atriv
      (if aconst
        (x862-one-targeted-reg-form seg aform areg)
        (x862-elide-pushes seg apushed (x862-pop-register seg areg))))
    (values areg breg creg)))

(defun x862-four-targeted-reg-forms (seg aform areg bform breg cform creg dform dreg)
  (unless (typep areg 'lreg)
    (warn "~s is not an lreg (1/4)" areg))
  (unless (typep breg 'lreg)
    (warn "~s is not an lreg (2/4)" breg))
  (unless (typep creg 'lreg)
    (warn "~s is not an lreg (3/4)" creg))
  (unless (typep dreg 'lreg)
    (warn "~s is not an lreg (4/4)" dreg))
  (let* ((atriv (or (null aform) 
                    (and (x862-trivial-p bform)
                         (x862-trivial-p cform)
                         (x862-trivial-p dform))))
         (btriv (or (null bform)
                    (and (x862-trivial-p cform)
                         (x862-trivial-p dform))))
         (ctriv (or (null cform)
                    (x862-trivial-p dform)))
         (aconst (and (not atriv) 
                      (or (x86-side-effect-free-form-p aform)
                          (let ((avar (x862-lexical-reference-p aform)))
                            (and avar 
                                 (x862-var-not-set-by-form-p avar bform)
                                 (x862-var-not-set-by-form-p avar cform)
                                 (x862-var-not-set-by-form-p avar dform))))))
         (bconst (and (not btriv)
                      (or
                       (x86-side-effect-free-form-p bform)
                       (let ((bvar (x862-lexical-reference-p bform)))
                         (and bvar
                              (x862-var-not-set-by-form-p bvar cform)
                              (x862-var-not-set-by-form-p bvar dform))))))
         (cconst (and (not ctriv)
                      (or
                       (x86-side-effect-free-form-p cform)
                       (let ((cvar (x862-lexical-reference-p cform)))
                         (and cvar (x862-var-not-set-by-form-p cvar dform))))))
         (apushed nil)
         (bpushed nil)
         (cpushed nil))
    (if (and aform (not aconst))
      (if atriv
        (x862-one-targeted-reg-form seg aform areg)
        (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg))))))
    (if (and bform (not bconst))
      (if btriv
        (x862-one-targeted-reg-form seg bform breg)
        (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg))))))
    (if (and cform (not cconst))
      (if ctriv
        (x862-one-targeted-reg-form seg cform creg)
        (setq cpushed (x862-push-register seg (x862-one-untargeted-reg-form seg cform (x862-acc-reg-for creg))))))
    (x862-one-targeted-reg-form seg dform dreg)
    (unless ctriv
      (if cconst
        (x862-one-targeted-reg-form seg cform creg)
        (x862-elide-pushes seg cpushed (x862-pop-register seg creg))))
    (unless btriv 
      (if bconst
        (x862-one-targeted-reg-form seg bform breg)
        (x862-elide-pushes seg bpushed (x862-pop-register seg breg))))
    (unless atriv
      (if aconst
        (x862-one-targeted-reg-form seg aform areg)
        (x862-elide-pushes seg apushed (x862-pop-register seg areg))))
    (values areg breg creg)))

(defun x862-three-untargeted-reg-forms (seg aform areg bform breg cform creg)
  (with-x86-local-vinsn-macros (seg)
    (let* ((atriv (or (null aform) 
                      (and (x862-trivial-p bform)
                           (x862-trivial-p cform))))
           (btriv (or (null bform)
                      (x862-trivial-p cform)))
           (aconst (and (not atriv) 
                        (or (x86-side-effect-free-form-p aform)
                            (let ((avar (x862-lexical-reference-p aform)))
                              (and avar 
                                   (x862-var-not-set-by-form-p avar bform)
                                   (x862-var-not-set-by-form-p avar cform))))))
           (bconst (and (not btriv)
                        (or
                         (x86-side-effect-free-form-p bform)
                         (let ((bvar (x862-lexical-reference-p bform)))
                           (and bvar (x862-var-not-set-by-form-p bvar cform))))))
           (adest areg)
           (bdest breg)
           (cdest creg)
           (apushed nil)
           (bpushed nil))
      (if (and aform (not aconst))
        (if atriv
          (setq adest (x862-one-untargeted-reg-form seg aform ($ areg)))
          (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg))))))
      (if (and bform (not bconst))
        (if btriv
          (setq bdest (x862-one-untargeted-reg-form seg bform ($ breg)))
          (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg))))))
      (setq cdest (x862-one-untargeted-reg-form seg cform creg))
      (unless btriv 
        (if bconst
          (setq bdest (x862-one-untargeted-reg-form seg bform breg))
          (x862-elide-pushes seg bpushed (x862-pop-register seg breg))))
      (unless atriv
        (if aconst
          (setq adest (x862-one-untargeted-reg-form seg aform areg))
          (x862-elide-pushes seg apushed (x862-pop-register seg areg))))
      (values adest bdest cdest))))

(defun x862-four-untargeted-reg-forms (seg aform areg bform breg cform creg dform dreg)
  (let* ((atriv (or (null aform) 
                    (and (x862-trivial-p bform)
                         (x862-trivial-p cform)
                         (x862-trivial-p dform))))
         (btriv (or (null bform)
                    (and (x862-trivial-p cform)
                         (x862-trivial-p dform))))
         (ctriv (or (null cform)
                    (x862-trivial-p dform)))
         (aconst (and (not atriv) 
                      (or (x86-side-effect-free-form-p aform)
                          (let ((avar (x862-lexical-reference-p aform)))
                            (and avar 
                                 (x862-var-not-set-by-form-p avar bform)
                                 (x862-var-not-set-by-form-p avar cform)
                                 (x862-var-not-set-by-form-p avar dform))))))
         (bconst (and (not btriv)
                      (or
                       (x86-side-effect-free-form-p bform)
                       (let ((bvar (x862-lexical-reference-p bform)))
                         (and bvar
                              (x862-var-not-set-by-form-p bvar cform)
                              (x862-var-not-set-by-form-p bvar dform))))))
         (cconst (and (not ctriv)
                      (or
                       (x86-side-effect-free-form-p cform)
                       (let ((cvar (x862-lexical-reference-p cform)))
                         (and cvar
                              (x862-var-not-set-by-form-p cvar dform))))))
         (adest areg)
         (bdest breg)
         (cdest creg)
         (ddest dreg)
         (apushed nil)
         (bpushed nil)
         (cpushed nil))
    (if (and aform (not aconst))
      (if atriv
        (setq adest (x862-one-targeted-reg-form seg aform areg))
        (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg))))))
    (if (and bform (not bconst))
      (if btriv
        (setq bdest (x862-one-untargeted-reg-form seg bform breg))
        (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg))))))
    (if (and cform (not cconst))
      (if ctriv
        (setq cdest (x862-one-untargeted-reg-form seg cform creg))
        (setq cpushed (x862-push-register seg (x862-one-untargeted-reg-form seg cform (x862-acc-reg-for creg))))))
    (setq ddest (x862-one-untargeted-reg-form seg dform dreg))
    (unless ctriv 
      (if cconst
        (setq cdest (x862-one-untargeted-reg-form seg cform creg))
        (x862-elide-pushes seg cpushed (x862-pop-register seg creg))))
    (unless btriv 
      (if bconst
        (setq bdest (x862-one-untargeted-reg-form seg bform breg))
        (x862-elide-pushes seg bpushed (x862-pop-register seg breg))))
    (unless atriv
      (if aconst
        (setq adest (x862-one-untargeted-reg-form seg aform areg))
        (x862-elide-pushes seg apushed (x862-pop-register seg areg))))
    (values adest bdest cdest ddest)))

(defun x862-lri (seg reg value)
  (with-x86-local-vinsn-macros (seg)
    (! lri reg value)))


(defun x862-multiple-value-body (seg form)
  (let* ((lab (backend-get-next-label))
         (*x862-vstack* *x862-vstack*)
         (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)
         (old-stack (x862-encode-stack)))
    (with-x86-local-vinsn-macros (seg)
      (x862-open-undo $undomvexpect)
      (x862-undo-body seg nil (logior $backend-mvpass-mask lab) form old-stack)
      (@ lab))))

(defun x862-afunc-lfun-ref (afunc)
  (or
   (afunc-lfun afunc)
   (progn (pushnew afunc (afunc-fwd-refs *x862-cur-afunc*) :test #'eq)
          afunc)))

(defun x862-augment-arglist (afunc arglist &optional (maxregs *x862-target-num-arg-regs*))
  (let ((inherited-args (afunc-inherited-vars afunc)))
    (when inherited-args
      (let* ((current-afunc *x862-cur-afunc*)
             (stkargs (car arglist))
             (regargs (cadr arglist))
             (inhforms nil)
             (numregs (length regargs))
             (own-inhvars (afunc-inherited-vars current-afunc)))
        (dolist (var inherited-args)
          (let* ((root-var (nx-root-var var))
                 (other-guy 
                  (dolist (v own-inhvars #|(error "other guy not found")|# root-var)
                    (when (eq root-var (nx-root-var v)) (return v)))))
            (push (make-acode (%nx1-operator inherited-arg) other-guy) inhforms)))
        (dolist (form inhforms)
          (if (%i< numregs maxregs)
            (progn
              (setq regargs (nconc regargs (list form)))
              (setq numregs (%i+ numregs 1)))
            (push form stkargs)))
        (%rplaca (%cdr arglist) regargs) ; might have started out NIL.
        (%rplaca arglist stkargs)))) 
  arglist)

(defun x862-acode-operator-supports-u8 (form)
  (setq form (acode-unwrapped-form form))
  (when (acode-p form)
    (let* ((operator (acode-operator form)))
      (if (member operator *x862-operator-supports-u8-target*)
        (values operator (acode-operand 1 form))))))

(defun x862-acode-operator-supports-push (form)
  (setq form (acode-unwrapped-form form))
  (when (acode-p form)
    (if (or (eq form *nx-t*)
            (eq form *nx-nil*)
            (let* ((operator (acode-operator form)))
              (member operator *x862-operator-supports-push*)))
        form)))

(defun x862-compare-u8 (seg vreg xfer form u8constant cr-bit true-p u8-operator)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (with-imm-target () (u8 :u8)
      (if (and (eql u8-operator (%nx1-operator lisptag))
               (eql 0 u8constant))
        (let* ((formreg (x862-one-untargeted-reg-form seg form x8664::arg_z)))
          
          (! set-flags-from-lisptag formreg))
        (progn
          (x862-use-operator u8-operator seg u8 nil form)
          (if (zerop u8constant)
            (! compare-u8-reg-to-zero u8)
            (! compare-u8-constant u8 u8constant))))
      ;; Flags set.  Branch or return a boolean value ?
      (setq cr-bit (x862-cr-bit-for-unsigned-comparison cr-bit))
      (regspec-crf-gpr-case 
       (vreg dest)
       (^ cr-bit true-p)
       (progn
         (ensuring-node-target (target dest)
           (if (not true-p)
             (setq cr-bit (logxor 1 cr-bit)))
           (! cr-bit->boolean target cr-bit))
         (^))))))

;;; There are other cases involving constants that are worth exploiting.
(defun x862-compare (seg vreg xfer i j cr-bit true-p)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (let* ((iu8 (let* ((i-fixnum (acode-fixnum-form-p i)))
                  (if (typep i-fixnum '(unsigned-byte 8))
                    i-fixnum)))
           (ju8 (let* ((j-fixnum (acode-fixnum-form-p j)))
                  (if (typep j-fixnum '(unsigned-byte 8))
                    j-fixnum)))
           (u8 (or iu8 ju8))
           (other-u8 (if iu8 j (if ju8 i)))
           (js32 (acode-s32-constant-p j))
           (is32 (acode-s32-constant-p i))
           (boolean (backend-crf-p vreg)))
      (multiple-value-bind (u8-operator u8-operand) (if other-u8 (x862-acode-operator-supports-u8 other-u8))
        (if u8-operator
          (x862-compare-u8 seg vreg xfer u8-operand u8 (if (and iu8 (not (eq cr-bit x86::x86-e-bits))) (logxor 1 cr-bit) cr-bit) true-p u8-operator)
          (if (and boolean (or js32 is32))
            (let* ((reg (x862-one-untargeted-reg-form seg (if js32 i j) x8664::arg_z))
                   (constant (or js32 is32)))
              (if (zerop constant)
                (! compare-reg-to-zero reg)
                (! compare-s32-constant reg (or js32 is32)))
              (unless (or js32 (eq cr-bit x86::x86-e-bits))
                (setq cr-bit (x862-reverse-cr-bit cr-bit)))
              (^ cr-bit true-p))
            (if (and ;(eq cr-bit x86::x86-e-bits) 
                     (or js32 is32))
              (progn
                (unless (or js32 (eq cr-bit x86::x86-e-bits))
                  (setq cr-bit (x862-reverse-cr-bit cr-bit)))
              (x862-test-reg-%izerop
               seg 
               vreg 
               xfer 
               (x862-one-untargeted-reg-form 
                seg 
                (if js32 i j) 
                x8664::arg_z) 
               cr-bit 
               true-p 
               (or js32 is32)))
              (multiple-value-bind (ireg jreg) (x862-two-untargeted-reg-forms seg i x8664::arg_y j x8664::arg_z)
                (x862-compare-registers seg vreg xfer ireg jreg cr-bit true-p)))))))))

(defun x862-natural-compare (seg vreg xfer i j cr-bit true-p)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (let* ((jconstant (acode-fixnum-form-p j))
           (ju31 (typep jconstant '(unsigned-byte 31)))
           (iconstant (acode-fixnum-form-p i))
           (iu31 (typep iconstant '(unsigned-byte 31)))
           (boolean (backend-crf-p vreg)))
      (if (and boolean (or ju31 iu31))
        (with-imm-target
            () (reg :natural)
            (x862-one-targeted-reg-form seg (if ju31 i j) reg)
            (! compare-u31-constant reg (if ju31 jconstant iconstant))
            (unless (or ju31 (eq cr-bit x86::x86-e-bits)) 
                (setq cr-bit (x862-reverse-cr-bit cr-bit)))
            (^ cr-bit true-p))
        (with-imm-target ()
          (ireg :natural)
            (with-imm-target 
                (ireg) (jreg :natural)
                (x862-two-targeted-reg-forms seg i ireg j jreg)
                (x862-compare-natural-registers seg vreg xfer ireg jreg cr-bit true-p)))))))


(defun x862-cr-bit-for-logical-comparison (cr-bit true-p)
  (declare (fixnum cr-bit))
  (let* ((unsigned
          (case cr-bit
            (#.x86::x86-l-bits x86::x86-b-bits)
            (#.x86::x86-le-bits x86::x86-be-bits )
            (#.x86::x86-g-bits x86::x86-a-bits)
            (#.x86::x86-ge-bits x86::x86-ae-bits)
            (t cr-bit))))
    (declare (fixnum unsigned))
    (if true-p
      unsigned
      (logxor unsigned 1))))
                 
(defun x862-compare-natural-registers (seg vreg xfer ireg jreg cr-bit true-p)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (if vreg
      (progn
        (setq cr-bit (x862-cr-bit-for-logical-comparison cr-bit true-p))
        (! compare ireg jreg)
        (regspec-crf-gpr-case 
         (vreg dest)
         (^ cr-bit true-p)
         (progn
           (ensuring-node-target (target dest)
             (! cr-bit->boolean target cr-bit))
           (^))))
      (^))))


(defun x862-compare-registers (seg vreg xfer ireg jreg cr-bit true-p)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (if vreg
      (progn
        (! compare ireg jreg)
        (regspec-crf-gpr-case 
         (vreg dest)
         (^ cr-bit true-p)
         (progn
           (ensuring-node-target (target dest)
             (if (not true-p)
               (setq cr-bit (logxor 1 cr-bit)))
             (! cr-bit->boolean target cr-bit))
           (^))))
      (^))))

(defun x862-compare-register-to-nil (seg vreg xfer ireg cr-bit true-p)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (when vreg
      (! compare-to-nil ireg)
      (regspec-crf-gpr-case 
       (vreg dest)
       (^ cr-bit true-p)
       (progn
       (ensuring-node-target (target dest)
         (if (not true-p)
           (setq cr-bit (logxor 1 cr-bit)))
         (! cr-bit->boolean target cr-bit))
       (^))))))

(defun x862-compare-ea-to-nil (seg vreg xfer ea cr-bit true-p)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (when vreg
      (if (addrspec-vcell-p ea)
        (with-node-target () temp
          (x862-stack-to-register seg ea temp)
          (! compare-value-cell-to-nil temp))
        (! compare-vframe-offset-to-nil (memspec-frame-address-offset ea) *x862-vstack*))
      (regspec-crf-gpr-case 
       (vreg dest)
       (^ cr-bit true-p)
       (progn
       (ensuring-node-target (target dest)
         (if (not true-p)
           (setq cr-bit (logxor 1 cr-bit)))
         (! cr-bit->boolean target cr-bit))
       (^))))))

(defun x862-cr-bit-for-unsigned-comparison (cr-bit)
  (ecase cr-bit
    (#.x86::x86-e-bits #.x86::x86-e-bits)
    (#.x86::x86-ne-bits #.x86::x86-ne-bits)
    (#.x86::x86-l-bits #.x86::x86-b-bits)
    (#.x86::x86-le-bits #.x86::x86-be-bits)
    (#.x86::x86-ge-bits #.x86::x86-ae-bits)
    (#.x86::x86-g-bits #.x86::x86-a-bits)))


(defun x862-compare-double-float-registers (seg vreg xfer ireg jreg cr-bit true-p)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (if vreg
      (progn
        (setq cr-bit (x862-cr-bit-for-unsigned-comparison cr-bit))
        (regspec-crf-gpr-case 
         (vreg dest)
         (progn
           (! double-float-compare ireg jreg)
           (^ cr-bit true-p))
         (progn
           (! double-float-compare ireg jreg)
           (ensuring-node-target (target dest)
             (if (not true-p)
               (setq cr-bit (logxor 1 cr-bit)))
             (! cr-bit->boolean target cr-bit))
           (^))))
      (^))))

(defun x862-compare-single-float-registers (seg vreg xfer ireg jreg cr-bit true-p)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (if vreg
      (progn
        (setq cr-bit (x862-cr-bit-for-unsigned-comparison cr-bit))
        (regspec-crf-gpr-case 
         (vreg dest)
         (progn
           (! single-float-compare ireg jreg)
           (^ cr-bit true-p))
         (progn
           (! single-float-compare ireg jreg)
           (ensuring-node-target (target dest)
             (if (not true-p)
               (setq cr-bit (logxor 1 cr-bit)))
             (! cr-bit->boolean target cr-bit))
         (^))))
      (^))))


(defun x862-immediate-form-p (form)
  (if (and (consp form)
           (or (eq (%car form) (%nx1-operator immediate))
               (eq (%car form) (%nx1-operator simple-function))))
    t))

(defun x862-test-%izerop (seg vreg xfer form cr-bit true-p)
  (x862-test-reg-%izerop seg vreg xfer (x862-one-untargeted-reg-form seg form x8664::arg_z) cr-bit true-p 0))

(defun x862-test-reg-%izerop (seg vreg xfer reg cr-bit true-p  zero)
  (declare (fixnum reg zero))
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (if (zerop zero)
      (! compare-reg-to-zero reg)
      (! compare-s32-constant reg zero))
    (regspec-crf-gpr-case 
     (vreg dest)
     (^ cr-bit true-p)
     (progn
       (ensuring-node-target (target dest)
         (if (not true-p)
           (setq cr-bit (logxor 1 cr-bit)))
         (! cr-bit->boolean target cr-bit))
       (^)))))

(defun x862-lexical-reference-ea (form &optional (no-closed-p t))
  (when (acode-p (setq form (acode-unwrapped-form form)))
    (if (eq (acode-operator form) (%nx1-operator lexical-reference))
      (let* ((addr (var-ea (%cadr form))))
        (if (typep addr 'lreg)
          addr
          (unless (and no-closed-p (addrspec-vcell-p addr ))
            addr))))))


(defun x862-vpush-register (seg src &optional why info attr)
  (with-x86-local-vinsn-macros (seg)
    (prog1
      (! vpush-register src)
      (setq *x862-tos-reg* src)
      (x862-new-vstack-lcell (or why :node) *x862-target-lcell-size* (or attr 0) info)
      (x862-adjust-vstack *x862-target-node-size*))))


;;; Need to track stack usage when pushing label for mv-call.
(defun x862-vpush-label (seg label)
  (with-x86-local-vinsn-macros (seg)
    (prog1
      (! vpush-label label)
      (x862-new-vstack-lcell :label *x862-target-lcell-size* 0 nil)
      (x862-adjust-vstack *x862-target-node-size*))))

(defun x862-temp-push-node (seg reg)
  (with-x86-local-vinsn-macros (seg)
    (! temp-push-node reg)
    (x862-open-undo $undostkblk)))

(defun x862-temp-pop-node (seg reg)
  (with-x86-local-vinsn-macros (seg)
    (! temp-pop-node reg)
    (x862-close-undo)))

(defun x862-vpush-register-arg (seg src)
  (x862-vpush-register seg src :outgoing-argument))


(defun x862-vpop-register (seg dest)
  (with-x86-local-vinsn-macros (seg)
    (prog1
      (! vpop-register dest)
      (setq *x862-top-vstack-lcell* (lcell-parent *x862-top-vstack-lcell*))
      (x862-adjust-vstack (- *x862-target-node-size*)))))

(defun x862-macptr->heap (seg dest src)
  (with-x86-local-vinsn-macros (seg)
    (! setup-macptr-allocation src)
    (! %allocate-uvector dest)
    (! %set-new-macptr-value dest)))

(defun x862-copy-register (seg dest src)
  (with-x86-local-vinsn-macros (seg)
    (when dest
      (let* ((dest-gpr (backend-ea-physical-reg dest hard-reg-class-gpr))
             (src-gpr (if src (backend-ea-physical-reg src hard-reg-class-gpr)))
             (dest-fpr (backend-ea-physical-reg dest hard-reg-class-fpr))
             (src-fpr (if src (backend-ea-physical-reg src hard-reg-class-fpr)))
             (src-mode (if src (get-regspec-mode src)))
             (dest-mode (get-regspec-mode dest))
             (dest-crf (backend-ea-physical-reg dest hard-reg-class-crf)))
        (if (null src)
          (if dest-gpr
            (! load-nil dest-gpr)
            (if dest-crf
              (! set-eq-bit)))
          (if (and dest-crf src-gpr)
            ;; "Copying" a GPR to a CR field means comparing it to rnil
            (! compare-to-nil src)
            (if (and dest-gpr src-gpr)
              (if (eq src-mode dest-mode)
                (unless (eq src-gpr dest-gpr)
                  (! copy-gpr dest src))
                ;; This is the "GPR <- GPR" case.  There are
                ;; word-size dependencies, but there's also
                ;; lots of redundancy here.
                (target-arch-case
                 (:x8664
                  (ecase dest-mode
                    (#.hard-reg-class-gpr-mode-node ; boxed result.
                     (case src-mode
                       (#.hard-reg-class-gpr-mode-node
                        (unless (eql  dest-gpr src-gpr)
                          (! copy-gpr dest src)))
                       (#.hard-reg-class-gpr-mode-u64
                        (x862-box-u64 seg dest src))
                       (#.hard-reg-class-gpr-mode-s64
                        (x862-box-s64 seg dest src))
                       (#.hard-reg-class-gpr-mode-u32
                        (x862-box-u32 seg dest src))
                       (#.hard-reg-class-gpr-mode-s32
                        (x862-box-s32 seg dest src))
                       (#.hard-reg-class-gpr-mode-u16
                        (! box-fixnum dest src))
                       (#.hard-reg-class-gpr-mode-s16
                        (! box-fixnum dest src))
                       (#.hard-reg-class-gpr-mode-u8
                        (! box-fixnum dest src))
                       (#.hard-reg-class-gpr-mode-s8
                        (! box-fixnum dest src))
                       (#.hard-reg-class-gpr-mode-address
                        (x862-macptr->heap seg dest src))))
                    ((#.hard-reg-class-gpr-mode-u64
                      #.hard-reg-class-gpr-mode-address)
                     (case src-mode
                       (#.hard-reg-class-gpr-mode-node
                        (let* ((src-type (get-node-regspec-type-modes src)))
                          (declare (fixnum src-type))
                          (case dest-mode
                            (#.hard-reg-class-gpr-mode-u64
                             (! unbox-u64 dest src))
                            (#.hard-reg-class-gpr-mode-address
                             (unless (or (logbitp #.hard-reg-class-gpr-mode-address src-type)
                                         *x862-reckless*)
                               (! trap-unless-macptr src))
                             (! deref-macptr dest src)))))
                       ((#.hard-reg-class-gpr-mode-u64
                         #.hard-reg-class-gpr-mode-s64
                         #.hard-reg-class-gpr-mode-address)
                        (unless (eql  dest-gpr src-gpr)
                          (! copy-gpr dest src)))
                       ((#.hard-reg-class-gpr-mode-u16
                         #.hard-reg-class-gpr-mode-s16)
                        (! u16->u32 dest src))
                       ((#.hard-reg-class-gpr-mode-u8
                         #.hard-reg-class-gpr-mode-s8)
                        (! u8->u32 dest src))))
                    (#.hard-reg-class-gpr-mode-s64
                     (case src-mode
                       (#.hard-reg-class-gpr-mode-node
                        (! unbox-s64 dest src))
                       ((#.hard-reg-class-gpr-mode-u64
                         #.hard-reg-class-gpr-mode-s64
                         #.hard-reg-class-gpr-mode-address)
                        (unless (eql  dest-gpr src-gpr)
                          (! copy-gpr dest src)))
                       ((#.hard-reg-class-gpr-mode-u16
                         #.hard-reg-class-gpr-mode-s16)
                        (! s16->s32 dest src))
                       ((#.hard-reg-class-gpr-mode-u8
                         #.hard-reg-class-gpr-mode-s8)
                        (! s8->s32 dest src))))
                    (#.hard-reg-class-gpr-mode-s32
                     (case src-mode
                       (#.hard-reg-class-gpr-mode-node
                        (! unbox-s32 dest src))
                       ((#.hard-reg-class-gpr-mode-u32
                         #.hard-reg-class-gpr-mode-s32
                         #.hard-reg-class-gpr-mode-address)
                        (unless (eql  dest-gpr src-gpr)
                          (! copy-gpr dest src)))
                       (#.hard-reg-class-gpr-mode-u16
                        (! u16->u32 dest src))                 
                       (#.hard-reg-class-gpr-mode-s16
                        (! s16->s32 dest src))
                       (#.hard-reg-class-gpr-mode-u8
                        (! u8->u32 dest src))
                       (#.hard-reg-class-gpr-mode-s8
                        (! s8->s32 dest src))))
                    (#.hard-reg-class-gpr-mode-u32
                     (case src-mode
                       (#.hard-reg-class-gpr-mode-node
                        (if *x862-reckless*
                          (! %unbox-u32 dest src)
                          (! unbox-u32 dest src)))
                       ((#.hard-reg-class-gpr-mode-u32
                         #.hard-reg-class-gpr-mode-s32)
                        (unless (eql  dest-gpr src-gpr)
                          (! copy-gpr dest src)))
                       (#.hard-reg-class-gpr-mode-u16
                        (! u16->u32 dest src))                 
                       (#.hard-reg-class-gpr-mode-s16
                        (! s16->s32 dest src))
                       (#.hard-reg-class-gpr-mode-u8
                        (! u8->u32 dest src))
                       (#.hard-reg-class-gpr-mode-s8
                        (! s8->s32 dest src))))
                    (#.hard-reg-class-gpr-mode-u16
                     (case src-mode
                       (#.hard-reg-class-gpr-mode-node
                        (if *x862-reckless*
                          (! %unbox-u16 dest src)
                          (! unbox-u16 dest src)))
                       ((#.hard-reg-class-gpr-mode-u8
                         #.hard-reg-class-gpr-mode-s8)
                        (! u8->u32 dest src))
                       (t
                        (unless (eql dest-gpr src-gpr)
                          (! copy-gpr dest src)))))
                    (#.hard-reg-class-gpr-mode-s16
                     (case src-mode
                       (#.hard-reg-class-gpr-mode-node
                        (! unbox-s16 dest src))
                       (#.hard-reg-class-gpr-mode-s8
                        (! s8->s32 dest src))
                       (#.hard-reg-class-gpr-mode-u8
                        (! u8->u32 dest src))
                       (t
                        (unless (eql dest-gpr src-gpr)
                          (! copy-gpr dest src)))))
                    (#.hard-reg-class-gpr-mode-u8
                     (case src-mode
                       (#.hard-reg-class-gpr-mode-node
                        (if *x862-reckless*
                          (! %unbox-u8 dest src)
                          (! unbox-u8 dest src)))
                       (t
                        (unless (eql dest-gpr src-gpr)
                          (! copy-gpr dest src)))))
                    (#.hard-reg-class-gpr-mode-s8
                     (case src-mode
                       (#.hard-reg-class-gpr-mode-node
                        (! unbox-s8 dest src))
                       (t
                        (unless (eql dest-gpr src-gpr)
                          (! copy-gpr dest src)))))))))
              (if src-gpr
                (if dest-fpr
                  (progn
                    (case src-mode
                      (#.hard-reg-class-gpr-mode-node
                       (case dest-mode
                         (#.hard-reg-class-fpr-mode-double
                          (unless (or (logbitp hard-reg-class-fpr-type-double 
                                           (get-node-regspec-type-modes src))
                                      *x862-reckless*)
                            (! trap-unless-double-float src))
                          (! get-double dest src))
                         (#.hard-reg-class-fpr-mode-single
                          (unless *x862-reckless* (! trap-unless-single-float src))
                          (! get-single dest src)))))))
                (if dest-gpr
                  (case dest-mode
                    (#.hard-reg-class-gpr-mode-node
                     (case src-mode
                       (#.hard-reg-class-fpr-mode-double
                        (x862-double->heap seg dest src))
                       (#.hard-reg-class-fpr-mode-single
                        (! single->node dest src)))))
                  (if (and src-fpr dest-fpr)
                    (unless (eql dest-fpr src-fpr)
                      (if (= src-mode hard-reg-class-fpr-mode-double)
                        (if (= dest-mode hard-reg-class-fpr-mode-double)
                          (! copy-double-float dest src)
                          (! copy-double-to-single dest src))
                        (if (= dest-mode hard-reg-class-fpr-mode-double)
                          (! copy-single-to-double dest src)
                          (! copy-single-float dest src))))))))))))))
  
(defun x862-unreachable-store (&optional vreg)
  ;; I don't think that anything needs to be done here,
  ;; but leave this guy around until we're sure.
  ;; (X862-VPUSH-REGISTER will always vpush something, even
  ;; if code to -load- that "something" never gets generated.
  ;; If I'm right about this, that means that the compile-time
  ;; stack-discipline problem that this is supposed to deal
  ;; with can't happen.)
  (declare (ignore vreg))
  nil)

;;; bind vars to initforms, as per let*, &aux.
(defun x862-seq-bind (seg vars initforms)
  (dolist (var vars)
    (x862-seq-bind-var seg var (pop initforms))))

(defun x862-target-is-imm-subtag (subtag)
  (when subtag
    (target-arch-case
     (:x8664
      (let* ((masked (logand subtag x8664::fulltagmask)))
        (declare (fixnum masked))
        (or (= masked x8664::fulltag-immheader-0)
            (= masked x8664::fulltag-immheader-1)
            (= masked x8664::fulltag-immheader-2)))))))

(defun x862-target-is-node-subtag (subtag)
  (when subtag
    (target-arch-case
     (:x8664
      (let* ((masked (logand subtag x8664::fulltagmask)))
        (declare (fixnum masked))
        (or (= masked x8664::fulltag-nodeheader-0)
            (= masked x8664::fulltag-nodeheader-1)))))))

(defun x862-dynamic-extent-form (seg curstack val)
  (when (acode-p val)
    (with-x86-local-vinsn-macros (seg)
      (let* ((op (acode-operator val)))
        (cond ((eq op (%nx1-operator list))
               (let* ((*x862-vstack* *x862-vstack*)
                      (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
                 (x862-set-nargs seg (x862-formlist seg (%cadr val) nil))
                 (x862-open-undo $undostkblk curstack)
                 (! stack-cons-list))
               (setq val x8664::arg_z))
              ((eq op (%nx1-operator list*))
               (let* ((arglist (%cadr val)))                   
                 (let* ((*x862-vstack* *x862-vstack*)
                        (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
                   (x862-formlist seg (car arglist) (cadr arglist)))
                 (when (car arglist)
                   (x862-set-nargs seg (length (%car arglist)))
                   (! stack-cons-list*)
                   (x862-open-undo $undostkblk curstack))
                 (setq val x8664::arg_z)))
              ((eq op (%nx1-operator multiple-value-list))
               (x862-multiple-value-body seg (%cadr val))
               (x862-open-undo $undostkblk curstack)
               (! stack-cons-list)
               (setq val x8664::arg_z))
              ((eq op (%nx1-operator cons))
               (let* ((y ($ x8664::arg_y))
                      (z ($ x8664::arg_z))
                      (result ($ x8664::arg_z)))
                 (x862-two-targeted-reg-forms seg (%cadr val) y (%caddr val) z)
                 (x862-open-undo $undostkblk )
                 (! make-tsp-cons result y z) 
                 (setq val result)))
              ((eq op (%nx1-operator %consmacptr%))
               (with-imm-target () (address :address)
                 (x862-one-targeted-reg-form seg val address)
                 (with-node-target () node
                   (! macptr->stack node address)
                   (x862-open-undo $undo-x86-c-frame)
                   (setq val node))))
              ((eq op (%nx1-operator %new-ptr))
               (let ((clear-form (caddr val)))
                 (if (nx-constant-form-p clear-form)
                   (progn 
                     (x862-one-targeted-reg-form seg (%cadr val) ($ x8664::arg_z))
                     (if (nx-null clear-form)
                       (! make-stack-block)
                       (! make-stack-block0)))
                   (with-crf-target () crf
                                    (let ((stack-block-0-label (backend-get-next-label))
                                          (done-label (backend-get-next-label))
                                          (rval ($ x8664::arg_z))
                                          (rclear ($ x8664::arg_y)))
                                      (x862-two-targeted-reg-forms seg (%cadr val) rval clear-form rclear)
                                      (! compare-to-nil crf rclear)
                                      (! cbranch-false (aref *backend-labels* stack-block-0-label) crf x86::x86-e-bits)
                                      (! make-stack-block)
                                      (-> done-label)
                                      (@ stack-block-0-label)
                                      (! make-stack-block0)
                                      (@ done-label)))))
               (x862-open-undo $undo-x86-c-frame)
               (setq val ($ x8664::arg_z)))
              ((eq op (%nx1-operator make-list))
               (x862-two-targeted-reg-forms seg (%cadr val) ($ x8664::arg_y) (%caddr val) ($ x8664::arg_z))
               (x862-open-undo $undostkblk curstack)
               (! make-stack-list)
               (setq val x8664::arg_z))       
              ((eq (%car val) (%nx1-operator vector))
               (let* ((*x862-vstack* *x862-vstack*)
                      (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
                 (x862-set-nargs seg (x862-formlist seg (%cadr val) nil))
                 (! make-stack-vector))
               (x862-open-undo $undostkblk)
               (setq val x8664::arg_z))
              ((eq op (%nx1-operator %gvector))
               (let* ((*x862-vstack* *x862-vstack*)
                      (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)
                      (arglist (%cadr val)))
                 (x862-set-nargs seg (x862-formlist seg (append (car arglist) (reverse (cadr arglist))) nil))
                 (! make-stack-gvector))
               (x862-open-undo $undostkblk)
               (setq val x8664::arg_z)) 
              ((eq op (%nx1-operator closed-function)) 
               (setq val (x862-make-closure seg (cadr val) t))) ; can't error
              ((eq op (%nx1-operator %make-uvector))
               (destructuring-bind (element-count subtag &optional (init 0 init-p)) (%cdr val)
                 (let* ((fix-subtag (acode-fixnum-form-p subtag))
                        (is-node (x862-target-is-node-subtag fix-subtag))
                        (is-imm  (x862-target-is-imm-subtag fix-subtag)))
                   (when (or is-node is-imm)
                     (if init-p
                       (progn
                         (x862-three-targeted-reg-forms seg element-count ($ x8664::arg_x) subtag ($ x8664::arg_y) init ($ x8664::arg_z))
                         (! stack-misc-alloc-init))
                       (progn
                         (x862-two-targeted-reg-forms seg element-count ($ x8664::arg_y)  subtag ($ x8664::arg_z))
                         (! stack-misc-alloc)))
                     (if is-node
                       (x862-open-undo $undostkblk)
                       (x862-open-undo $undo-x86-c-frame))
                     (setq val ($ x8664::arg_z))))))))))
  val)

(defun x862-addrspec-to-reg (seg addrspec reg)
  (if (memory-spec-p addrspec)
    (x862-stack-to-register seg addrspec reg)
    (x862-copy-register seg reg addrspec)))
  
(defun x862-seq-bind-var (seg var val)
  (with-x86-local-vinsn-macros (seg)
    (let* ((sym (var-name var))
           (bits (nx-var-bits var))
           (closed-p (and (%ilogbitp $vbitclosed bits)
                          (%ilogbitp $vbitsetq bits)))
           (curstack (x862-encode-stack))
           (make-vcell (and closed-p (eq bits (var-bits var))))
           (closed-downward (and closed-p (%ilogbitp $vbitcloseddownward bits))))
      (unless (fixnump val)
        (setq val (nx-untyped-form val))
        (when (and (%ilogbitp $vbitdynamicextent bits) (acode-p val))
          (setq val (x862-dynamic-extent-form seg curstack val))))
      (if (%ilogbitp $vbitspecial bits)
        (progn
          (x862-dbind seg val sym)
          (x862-set-var-ea seg var (x862-vloc-ea (- *x862-vstack* *x862-target-node-size*))))
        (let ((puntval nil))
          (flet ((x862-puntable-binding-p (var initform)
                   ;; The value returned is acode.
                   (let* ((bits (nx-var-bits var)))
                     (if (%ilogbitp $vbitpuntable bits)
                       (nx-untyped-form initform)))))
            (declare (inline x862-puntable-binding-p))
            (if (and (not (x862-load-ea-p val))
                     (setq puntval (x862-puntable-binding-p var val)))
              (progn
                (nx-set-var-bits var (%ilogior (%ilsl $vbitpunted 1) bits))
                (x862-set-var-ea seg var puntval))
              (progn
                (let* ((vloc *x862-vstack*)
                       (reg (let* ((r (x862-assign-register-var var)))
                              (if r ($ r)))))
                  (if (x862-load-ea-p val)
                    (if reg
                      (x862-addrspec-to-reg seg val reg)
                      (if (memory-spec-p val)
                        (with-node-temps () (temp)
                          (x862-addrspec-to-reg seg val temp)
                          (x862-vpush-register seg temp :node var bits))
                        (x862-vpush-register seg val :node var bits)))
                    (if reg
                      (x862-one-targeted-reg-form seg val reg)
                      (let* ((pushform (x862-acode-operator-supports-push val)))
                        (if pushform
                          (progn
                            (x862-form seg :push nil pushform)
                            (x862-new-vstack-lcell :node *x862-target-lcell-size* bits var)
                            (x862-adjust-vstack *x862-target-node-size*))
                          (x862-vpush-register seg (x862-one-untargeted-reg-form seg val x8664::arg_z) :node var bits)))))
                  (x862-set-var-ea seg var (or reg (x862-vloc-ea vloc closed-p)))
                  (if reg
                    (x862-note-var-cell var reg)
                    (x862-note-top-cell var))
                  (when make-vcell
                    (with-node-target (x8664::allocptr) closed
                      (with-node-target (x8664::allocptr closed) vcell
                        (x862-stack-to-register seg vloc closed)
                        (if closed-downward
                          (progn
                            (! make-tsp-vcell vcell closed)
                            (x862-open-undo $undostkblk))
                          (progn
                            (! setup-vcell-allocation)
                            (! %allocate-uvector vcell)
                            (! %init-vcell vcell closed)))
                        (x862-register-to-stack seg vcell vloc)))))))))))))



;;; Never make a vcell if this is an inherited var.
;;; If the var's inherited, its bits won't be a fixnum (and will
;;; therefore be different from what NX-VAR-BITS returns.)
(defun x862-bind-var (seg var vloc &optional lcell &aux 
                          (bits (nx-var-bits var)) 
                          (closed-p (and (%ilogbitp $vbitclosed bits) (%ilogbitp $vbitsetq bits)))
                          (closed-downward (if closed-p (%ilogbitp $vbitcloseddownward bits)))
                          (make-vcell (and closed-p (eq bits (var-bits var))))
                          (addr (x862-vloc-ea vloc)))
  (with-x86-local-vinsn-macros (seg)
    (if (%ilogbitp $vbitspecial bits)
      (progn
        (x862-dbind seg addr (var-name var))
        (x862-set-var-ea seg var (x862-vloc-ea (- *x862-vstack* *x862-target-node-size*)))
        t)
      (progn
        (when (%ilogbitp $vbitpunted bits)
          (compiler-bug "bind-var: var ~s was punted" var))
        (when make-vcell
          (with-node-target (x8664::allocptr) closed
            (with-node-target (x8664::allocptr closed) vcell
              (x862-stack-to-register seg vloc closed)
              (if closed-downward
                (progn
                  (! make-tsp-vcell vcell closed)
                  (x862-open-undo $undostkblk))
                (progn
                  (! setup-vcell-allocation)
                  (! %allocate-uvector vcell)
                  (! %init-vcell vcell closed)))
              (x862-register-to-stack seg vcell vloc))))
        (when lcell
          (setf (lcell-kind lcell) :node
                (lcell-attributes lcell) bits
                (lcell-info lcell) var)
          (x862-note-var-cell var lcell))          
        (x862-set-var-ea seg var (x862-vloc-ea vloc closed-p))        
        closed-downward))))

(defun x862-set-var-ea (seg var ea)
  (setf (var-ea var) ea)
  (when (and *x862-record-symbols* (or (typep ea 'lreg) (typep ea 'fixnum)))
    (let* ((start (x862-emit-note seg :begin-variable-scope)))
      (push (list var (var-name var) start (close-vinsn-note start))
            *x862-recorded-symbols*)))
  ea)

(defun x862-close-var (seg var)
  (let ((bits (nx-var-bits var)))
    (when (and *x862-record-symbols*
               (or (logbitp $vbitspecial bits)
                   (not (logbitp $vbitpunted bits))))
      (let ((endnote (%car (%cdddr (assq var *x862-recorded-symbols*)))))
        (unless endnote (compiler-bug "x862-close-var for ~s" (var-name var)))
        (setf (vinsn-note-class endnote) :end-variable-scope)
        (append-dll-node (vinsn-note-label endnote) seg)))))

(defun x862-load-ea-p (ea)
  (or (typep ea 'fixnum)
      (typep ea 'lreg)
      (typep ea 'lcell)))

(defun x862-dbind (seg value sym)
  (with-x86-local-vinsn-macros (seg)
    (let* ((ea-p (x862-load-ea-p value))
           (nil-p (unless ea-p (eq (setq value (nx-untyped-form value)) *nx-nil*)))
           (self-p (unless ea-p (and (or
                                      (eq (acode-operator value) (%nx1-operator bound-special-ref))
                                      (eq (acode-operator value) (%nx1-operator special-ref)))
                                     (eq (cadr value) sym)))))
      (cond ((eq sym '*interrupt-level*)
             (let* ((fixval (acode-fixnum-form-p value)))
               (cond ((eql fixval 0)
                      (if *x862-open-code-inline*
                        (! bind-interrupt-level-0-inline)
                        (! bind-interrupt-level-0)))
                     ((eql fixval -1)
                      (if *x862-open-code-inline*
                        (! bind-interrupt-level-m1-inline)
                        (! bind-interrupt-level-m1)))
                     (t
                      (if ea-p 
                        (x862-store-ea seg value x8664::arg_z)
                        (x862-one-targeted-reg-form seg value ($ x8664::arg_z)))
                      (! bind-interrupt-level))))
             (x862-open-undo $undointerruptlevel))
            (t
             (if (or nil-p self-p)
               (progn
                 (x862-store-immediate seg (x862-symbol-value-cell sym) x8664::arg_z)
                 (if nil-p
                   (! bind-nil)
                   (if (or *x862-reckless* (eq (acode-operator value) (%nx1-operator special-ref)))
                     (! bind-self)
                     (! bind-self-boundp-check))))
               (progn
                 (if ea-p 
                   (x862-store-ea seg value x8664::arg_z)
                   (x862-one-targeted-reg-form seg value ($ x8664::arg_z)))
                 (x862-store-immediate seg (x862-symbol-value-cell sym) ($ x8664::arg_y))
                 (! bind)))
             (x862-open-undo $undospecial)))
      (x862-new-vstack-lcell :special-value *x862-target-lcell-size* 0 sym)
      (x862-new-vstack-lcell :special *x862-target-lcell-size* (ash 1 $vbitspecial) sym)
      (x862-new-vstack-lcell :special-link *x862-target-lcell-size* 0 sym)
      (x862-adjust-vstack (* 3 *x862-target-node-size*)))))

;;; Store the contents of EA - which denotes either a vframe location
;;; or a hard register - in reg.

(defun x862-store-ea (seg ea reg)
  (if (typep ea 'fixnum)
    (if (memory-spec-p ea)
      (x862-stack-to-register seg ea reg)
      (x862-copy-register seg reg ea))
    (if (typep ea 'lreg)
      (x862-copy-register seg reg ea)
      (if (typep ea 'lcell)
        (x862-lcell-to-register seg ea reg)))))


      

;;; Callers should really be sure that this is what they want to use.
(defun x862-absolute-natural (seg vreg xfer value)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (when vreg
      (x862-lri seg vreg value))
    (^)))



(defun x862-store-macptr (seg vreg address-reg)
  (with-x86-local-vinsn-macros (seg vreg)
    (when (x862-for-value-p vreg)
      (if (logbitp vreg *backend-imm-temps*)
        (<- address-reg)
        (x862-macptr->heap seg vreg address-reg)))))

(defun x862-store-signed-longword (seg vreg imm-reg)
  (with-x86-local-vinsn-macros (seg vreg)
    (when (x862-for-value-p vreg)
      (if (logbitp vreg *backend-imm-temps*)
        (<- imm-reg)
        (x862-box-s32 seg vreg imm-reg)))))




(defun x862-%immediate-set-ptr (seg vreg xfer  ptr offset val)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (let* ((intval (acode-absolute-ptr-p val t))
           (offval (acode-fixnum-form-p offset))
           (for-value (x862-for-value-p vreg)))
      (flet ((address-and-node-regs ()
               (if for-value
                 (progn
                   (x862-one-targeted-reg-form seg val ($ x8664::arg_z))
                   (progn
                       (if intval
                         (x862-lri seg x8664::imm0 intval)
                         (! deref-macptr x8664::imm0 x8664::arg_z))
                       (values x8664::imm0 x8664::arg_z)))
                 (values (x862-macptr-arg-to-reg seg val ($ x8664::imm0 :mode :address)) nil))))
        (unless (typep offval '(signed-byte 32))
          (setq offval nil))
        (unless (typep intval '(signed-byte 32))
          (setq intval nil))
        (cond (intval
               (cond (offval
                      (with-imm-target () (ptr-reg :address)
                        (let* ((ptr-reg (x862-one-untargeted-reg-form seg
                                                                      ptr
                                                                      ptr-reg)))
                          (! mem-set-c-constant-doubleword intval ptr-reg offval))))
                     (t
                      (with-imm-target () (ptr-reg :address)
                        (with-imm-target (ptr-reg) (offsetreg :signed-natural)
                          (x862-two-targeted-reg-forms seg ptr ptr-reg offset ($ x8664::arg_z))
                          (! fixnum->signed-natural offsetreg x8664::arg_z)
                          (! mem-set-constant-doubleword intval ptr-reg offsetreg)))))
               (if for-value
                 (with-imm-target () (val-reg :s64)
                   (x862-lri seg val-reg intval)
                   (<- (set-regspec-mode val-reg (gpr-mode-name-value :address))))))
              (offval
               ;; Still simpler than the general case
               (with-imm-target () (ptr-reg :address)
                 (x862-push-register seg
                                     (x862-one-untargeted-reg-form seg ptr ptr-reg)))
               (multiple-value-bind (address node)
                   (address-and-node-regs)
                 (with-imm-target (address) (ptr-reg :address)
                   (x862-pop-register seg ptr-reg)
                   (! mem-set-c-doubleword address ptr-reg offval))
                 (if for-value
                   (<- node))))
              (t
               (with-imm-target () (ptr-reg :address)
                 (with-imm-target (ptr-reg) (offset-reg :address)
                   (x862-two-targeted-reg-forms seg ptr ptr-reg offset ($ x8664::arg_z))
                   (! fixnum->signed-natural offset-reg x8664::arg_z)
                   (! fixnum-add2 ptr-reg offset-reg)
                   (x862-push-register seg ptr-reg)))
               (multiple-value-bind (address node)
                   (address-and-node-regs)
                 (with-imm-target (address) (ptr-reg :address)
                   (x862-pop-register seg ptr-reg)
                   (! mem-set-c-doubleword address ptr-reg 0))
                 (if for-value
                   (<- node))))))
      (^))))
                     
  

      
(defun x862-%immediate-store  (seg vreg xfer bits ptr offset val)
  (with-x86-local-vinsn-macros (seg vreg xfer)
    (if (eql 0 (%ilogand #xf bits))
      (x862-%immediate-set-ptr seg vreg xfer  ptr offset val)
      (let* ((size (logand #xf bits))
             (signed (not (logbitp 5 bits)))
             (nbits (ash size 3))
             (intval (acode-integer-constant-p val nbits))
             (ncbits (if (eql nbits 64) 32 nbits))
             (signed-intval (or (and intval
                                     (> intval 0)
                                     (logbitp (1- ncbits) intval)
                                     (- intval (ash 1 ncbits)))
                                intval))
             (offval (acode-fixnum-form-p offset))
             (for-value (x862-for-value-p vreg)))
        (declare (fixnum size))
        (flet ((val-to-argz-and-imm0 ()
                 (x862-one-targeted-reg-form seg val ($ x8664::arg_z))
                 (if (eq size 8)
                   (if signed
                     (! gets64)
                     (! getu64))
                   (! fixnum->signed-natural x8664::imm0 x8664::arg_z))))

          (and offval (%i> (integer-length offval) 31) (setq offval nil))
          (and intval (%i> (integer-length intval) 31) (setq intval nil))
    Â