source: trunk/source/compiler/X86/x862.lisp @ 10333

Last change on this file since 10333 was 10333, checked in by rme, 12 years ago

x862-typechecked-form: changes for x8632

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 429.5 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2005, Clozure Associates
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(eval-when (:compile-toplevel :execute)
20  (require "NXENV")
21  (require "X8632ENV")
22  (require "X8664ENV"))
23
24(eval-when (:load-toplevel :execute :compile-toplevel)
25  (require "X86-BACKEND"))
26
27(defparameter *x862-debug-mask* 0)
28(defconstant x862-debug-verbose-bit 0)
29(defconstant x862-debug-vinsns-bit 1)
30(defconstant x862-debug-lcells-bit 2)
31(defparameter *x862-target-lcell-size* 0)
32(defparameter *x862-target-node-size* 0)
33(defparameter *x862-target-dnode-size* 0)
34(defparameter *x862-target-fixnum-shift* 0)
35(defparameter *x862-target-node-shift* 0)
36(defparameter *x862-target-bits-in-word* 0)
37(defparameter *x862-target-num-arg-regs* 0)
38(defparameter *x862-target-num-save-regs* 0)
39(defparameter *x862-target-half-fixnum-type* nil)
40
41(defparameter *x862-operator-supports-u8-target* ())
42(defparameter *x862-operator-supports-push* ())
43(defparameter *x862-tos-reg* ())
44
45;; probably should be elsewhere
46
47(defmacro with-additional-imm-reg ((&rest reserved) &body body)
48  (let ((node (gensym))
49        (bit (gensym)))
50    `(target-arch-case
51      (:x8632
52       (with-node-target (,@reserved) ,node
53         (let* ((,bit (ash 1 (hard-regspec-value ,node)))
54                (*backend-node-temps* (logandc2 *backend-node-temps* ,bit))
55                (*available-backend-node-temps* (logandc2 *available-backend-node-temps* ,bit))
56                (*backend-imm-temps* (logior *backend-imm-temps* ,bit))
57                (*available-backend-imm-temps* (logior *available-backend-imm-temps* ,bit)))
58           (! mark-as-imm ,node)
59           ,@body
60           (! mark-as-node ,node))))
61      (:x8664
62       (progn
63         ,@body)))))
64
65 
66(defun x862-immediate-operand (x)
67  (if (eq (acode-operator x) (%nx1-operator immediate))
68    (cadr x)
69    (compiler-bug "not an immediate: ~s" x)))
70
71(defmacro with-x86-p2-declarations (declsform &body body)
72  `(let* ((*x862-tail-allow* *x862-tail-allow*)
73          (*x862-reckless* *x862-reckless*)
74          (*x862-open-code-inline* *x862-open-code-inline*)
75          (*x862-trust-declarations* *x862-trust-declarations*))
76     (x862-decls ,declsform)
77     ,@body))
78
79
80(defmacro with-x86-local-vinsn-macros ((segvar &optional vreg-var xfer-var) &body body)
81  (declare (ignorable xfer-var))
82  (let* ((template-name-var (gensym))
83         (template-temp (gensym))
84         (args-var (gensym))
85         (labelnum-var (gensym))
86         (retvreg-var (gensym))
87         (label-var (gensym)))
88    `(macrolet ((! (,template-name-var &rest ,args-var)                 
89                  (let* ((,template-temp (get-vinsn-template-cell ,template-name-var (backend-p2-vinsn-templates *target-backend*))))
90                    (unless ,template-temp
91                      (warn "VINSN \"~A\" not defined" ,template-name-var))
92                    `(prog1
93                      (%emit-vinsn ,',segvar ',,template-name-var (backend-p2-vinsn-templates *target-backend*) ,@,args-var)
94                      (setq *x862-tos-reg* nil)))))
95       (macrolet ((<- (,retvreg-var)
96                    `(x862-copy-register ,',segvar ,',vreg-var ,,retvreg-var))
97                  (@  (,labelnum-var)
98                    `(backend-gen-label ,',segvar ,,labelnum-var))
99                  (@= (,labelnum-var)
100                    `(x862-emit-aligned-label ,',segvar ,,labelnum-var))
101                  (-> (,label-var)
102                    `(! jump (aref *backend-labels* ,,label-var)))
103                  (^ (&rest branch-args)
104                    `(x862-branch ,',segvar ,',xfer-var ,@branch-args))
105                  (? (&key (class :gpr)
106                          (mode :lisp))
107                   (let* ((class-val
108                           (ecase class
109                             (:gpr hard-reg-class-gpr)
110                             (:fpr hard-reg-class-fpr)
111                             (:crf hard-reg-class-crf)))
112                          (mode-val-or-form
113                           (if (eq class :gpr)
114                             (if (member mode '(:natural :signed-natural))
115                               `(gpr-mode-name-value ,mode)
116                               (gpr-mode-name-value mode))
117                             (if (eq class :fpr)
118                               (if (eq mode :single-float)
119                                 hard-reg-class-fpr-mode-single
120                                 hard-reg-class-fpr-mode-double)
121                               0))))
122                     `(make-unwired-lreg nil
123                       :class ,class-val
124                       :mode ,mode-val-or-form)))
125                  ($ (reg &key (class :gpr) (mode :lisp))
126                   (let* ((class-val
127                           (ecase class
128                             (:gpr hard-reg-class-gpr)
129                             (:fpr hard-reg-class-fpr)
130                             (:crf hard-reg-class-crf)))
131                          (mode-val-or-form
132                           (if (eq class :gpr)
133                             (if (member mode '(:natural :signed-natural))
134                               `(gpr-mode-name-value ,mode)
135                               (gpr-mode-name-value mode))
136                             (if (eq class :fpr)
137                               (if (eq mode :single-float)
138                                 hard-reg-class-fpr-mode-single
139                                 hard-reg-class-fpr-mode-double)
140                               0))))
141                     `(make-wired-lreg ,reg
142                       :class ,class-val
143                       :mode ,mode-val-or-form))))
144         ,@body))))
145
146
147
148(defvar *x86-current-context-annotation* nil)
149(defvar *x862-woi* nil)
150(defvar *x862-open-code-inline* nil)
151(defvar *x862-register-restore-count* 0)
152(defvar *x862-register-restore-ea* nil)
153(defvar *x862-compiler-register-save-label* nil)
154(defvar *x862-valid-register-annotations* 0)
155(defvar *x862-register-annotation-types* nil)
156(defvar *x862-register-ea-annotations* nil)
157(defvar *x862-constant-alist* nil)
158(defvar *x862-double-float-constant-alist* nil)
159(defvar *x862-single-float-constant-alist* nil)
160
161(defparameter *x862-tail-call-aliases*
162  ()
163  #| '((%call-next-method . (%tail-call-next-method . 1))) |#
164 
165)
166
167(defvar *x862-popreg-labels* nil)
168(defvar *x862-popj-labels* nil)
169(defvar *x862-valret-labels* nil)
170(defvar *x862-nilret-labels* nil)
171
172(defvar *x862-icode* nil)
173(defvar *x862-undo-stack* nil)
174(defvar *x862-undo-because* nil)
175
176
177(defvar *x862-cur-afunc* nil)
178(defvar *x862-vstack* 0)
179(defvar *x862-cstack* 0)
180(defvar *x862-undo-count* 0)
181(defvar *x862-returning-values* nil)
182(defvar *x862-vcells* nil)
183(defvar *x862-fcells* nil)
184(defvar *x862-entry-vsp-saved-p* nil)
185
186(defvar *x862-entry-label* nil)
187(defvar *x862-tail-label* nil)
188(defvar *x862-tail-vsp* nil)
189(defvar *x862-tail-nargs* nil)
190(defvar *x862-tail-allow* t)
191(defvar *x862-reckless* nil)
192(defvar *x862-trust-declarations* nil)
193(defvar *x862-entry-vstack* nil)
194(defvar *x862-fixed-nargs* nil)
195(defvar *x862-need-nargs* t)
196
197(defparameter *x862-inhibit-register-allocation* nil)
198(defvar *x862-record-symbols* nil)
199(defvar *x862-recorded-symbols* nil)
200
201(defvar *x862-result-reg* x8664::arg_z)
202
203(defvar *x862-arg-z* nil)
204(defvar *x862-arg-y* nil)
205(defvar *x862-imm0* nil)
206(defvar *x862-temp0* nil)
207(defvar *x862-temp1* nil)
208(defvar *x862-fn* nil)
209(defvar *x862-fname* nil)
210(defvar *x862-ra0* nil)
211
212(defvar *x862-allocptr* nil)
213
214(defvar *x862-fp0* nil)
215(defvar *x862-fp1* nil)
216
217(declaim (fixnum *x862-vstack* *x862-cstack*))
218
219 
220
221
222
223(defvar *x862-all-lcells* ())
224
225(defun x86-immediate-label (imm)
226  (or (cdr (assoc imm *x862-constant-alist* :test #'eq))
227      (let* ((lab (aref *backend-labels* (backend-get-next-label))))
228        (push (cons imm lab) *x862-constant-alist*)
229        lab)))
230
231(defun x86-double-float-constant-label (imm)
232  (or (cdr (assoc imm *x862-double-float-constant-alist*))
233      (let* ((lab (aref *backend-labels* (backend-get-next-label))))
234        (push (cons imm lab) *x862-double-float-constant-alist*)
235        lab)))
236
237(defun x86-single-float-constant-label (imm)
238  (or (cdr (assoc imm *x862-single-float-constant-alist*))
239      (let* ((lab (aref *backend-labels* (backend-get-next-label))))
240        (push (cons imm lab) *x862-single-float-constant-alist*)
241        lab)))
242
243
244(defun x862-free-lcells ()
245  (without-interrupts 
246   (let* ((prev (pool.data *lcell-freelist*)))
247     (dolist (r *x862-all-lcells*)
248       (setf (lcell-kind r) prev
249             prev r))
250     (setf (pool.data *lcell-freelist*) prev)
251     (setq *x862-all-lcells* nil))))
252
253(defun x862-note-lcell (c)
254  (push c *x862-all-lcells*)
255  c)
256
257(defvar *x862-top-vstack-lcell* ())
258(defvar *x862-bottom-vstack-lcell* ())
259
260(defun x862-new-lcell (kind parent width attributes info)
261  (x862-note-lcell (make-lcell kind parent width attributes info)))
262
263(defun x862-new-vstack-lcell (kind width attributes info)
264  (setq *x862-top-vstack-lcell* (x862-new-lcell kind *x862-top-vstack-lcell* width attributes info)))
265
266(defun x862-reserve-vstack-lcells (n)
267  (dotimes (i n) (x862-new-vstack-lcell :reserved *x862-target-lcell-size* 0 nil)))
268
269(defun x862-vstack-mark-top ()
270  (x862-new-lcell :tos *x862-top-vstack-lcell* 0 0 nil))
271
272;;; Alist mapping VARs to lcells/lregs
273(defvar *x862-var-cells* ())
274
275(defun x862-note-var-cell (var cell)
276  ;(format t "~& ~s -> ~s" (var-name var) cell)
277  (push (cons var cell) *x862-var-cells*))
278
279(defun x862-note-top-cell (var)
280  (x862-note-var-cell var *x862-top-vstack-lcell*))
281
282(defun x862-lookup-var-cell (var)
283  (or (cdr (assq var *x862-var-cells*))
284      (and nil (warn "Cell not found for ~s" (var-name var)))))
285
286(defun x862-collect-lcells (kind &optional (bottom *x862-bottom-vstack-lcell*) (top *x862-top-vstack-lcell*))
287  (do* ((res ())
288        (cell top (lcell-parent cell)))
289       ((eq cell bottom) res)
290    (if (null cell)
291      (compiler-bug "Horrible compiler bug.")
292      (if (eq (lcell-kind cell) kind)
293        (push cell res)))))
294
295
296 
297;;; ensure that lcell's offset matches what we expect it to.
298;;; For bootstrapping.
299
300(defun x862-ensure-lcell-offset (c expected)
301  (if c (= (calc-lcell-offset c) expected) (zerop expected)))
302
303(defun x862-check-lcell-depth (&optional (context "wherever"))
304  (when (logbitp x862-debug-verbose-bit *x862-debug-mask*)
305    (let* ((depth (calc-lcell-depth *x862-top-vstack-lcell*)))
306      (or (= depth *x862-vstack*)
307          (warn "~a: lcell depth = ~d, vstack = ~d" context depth *x862-vstack*)))))
308
309(defun x862-do-lexical-reference (seg vreg ea)
310  (when vreg
311    (with-x86-local-vinsn-macros (seg vreg)
312      (if (eq vreg :push)
313        (if (memory-spec-p ea)
314          (if (addrspec-vcell-p ea)
315            (with-node-target () target
316              (x862-stack-to-register seg ea target)
317              (! vcell-ref target target)
318              (! vpush-register target))
319            (! vframe-push (memspec-frame-address-offset ea) *x862-vstack*))
320          (! vpush-register ea))
321        (if (memory-spec-p ea)
322          (ensuring-node-target (target vreg)
323            (progn
324              (x862-stack-to-register seg ea target)
325              (if (addrspec-vcell-p ea)
326                (! vcell-ref target target))))
327          (<- ea))))))
328
329(defun x862-do-lexical-setq (seg vreg ea valreg)
330  (with-x86-local-vinsn-macros (seg vreg)
331    (cond ((typep ea 'lreg)
332            (x862-copy-register seg ea valreg))
333          ((addrspec-vcell-p ea)     ; closed-over vcell
334           (x862-copy-register seg *x862-arg-z* valreg)
335           (let* ((gvector (target-arch-case (:x8632 x8632::temp0)
336                                             (:x8664 x8664::arg_x))))
337             (x862-stack-to-register seg ea gvector)
338             (x862-lri seg *x862-arg-y* 0)
339             (! call-subprim-3 *x862-arg-z* (subprim-name->offset '.SPgvset) gvector *x862-arg-y* *x862-arg-z*)))
340          ((memory-spec-p ea)    ; vstack slot
341           (x862-register-to-stack seg valreg ea))
342          (t
343           (x862-copy-register seg ea valreg)))
344    (when vreg
345      (<- valreg))))
346
347;;; ensure that next-method-var is heap-consed (if it's closed over.)
348;;; it isn't ever setqed, is it ?
349(defun x862-heap-cons-next-method-var (seg var)
350  (with-x86-local-vinsn-macros (seg)
351    (when (eq (ash 1 $vbitclosed)
352              (logand (logior (ash 1 $vbitclosed)
353                              (ash 1 $vbitcloseddownward))
354                      (the fixnum (nx-var-bits var))))
355      (let* ((ea (var-ea var))
356             (arg ($ *x862-arg-z*))
357             (result ($ *x862-arg-z*)))
358        (x862-do-lexical-reference seg arg ea)
359        (x862-set-nargs seg 1)
360        (! ref-constant ($ *x862-fname*) (x86-immediate-label (x862-symbol-entry-locative '%cons-magic-next-method-arg)))
361        (! call-known-symbol arg)
362        (x862-do-lexical-setq seg nil ea result)))))
363
364;;; If we change the order of operands in a binary comparison operation,
365;;; what should the operation change to ? (eg., (< X Y) means the same
366;;; thing as (> Y X)).
367(defparameter *x862-reversed-cr-bits*
368  (vector
369   nil                                  ;o ?
370   nil                                  ;no ?
371   x86::x86-a-bits                      ;b -> a
372   x86::x86-be-bits                     ;ae -> be
373   x86::x86-e-bits                      ;e->e
374   x86::x86-ne-bits                     ;ne->ne
375   x86::x86-ae-bits                     ;be->ae
376   x86::x86-b-bits                      ;a->b
377   nil                                  ;s ?
378   nil                                  ;ns ?
379   nil                                  ;pe ?
380   nil                                  ;po ?
381   x86::x86-g-bits                      ;l->g
382   x86::x86-le-bits                     ;ge->le
383   x86::x86-ge-bits                     ;le->ge
384   x86::x86-l-bits                      ;g->l
385   ))
386
387(defun x862-reverse-cr-bit (cr-bit)
388  (or (svref *x862-reversed-cr-bits* cr-bit)
389      (compiler-bug "Can't reverse CR bit ~d" cr-bit)))
390
391
392(defun acode-condition-to-x86-cr-bit (cond)
393  (condition-to-x86-cr-bit (cadr cond)))
394
395(defun condition-to-x86-cr-bit (cond)
396  (case cond
397    (:EQ (values x86::x86-e-bits t))
398    (:NE (values x86::x86-e-bits nil))
399    (:GT (values x86::x86-le-bits nil))
400    (:LE (values x86::x86-le-bits t))
401    (:LT (values x86::x86-l-bits t))
402    (:GE (values x86::x86-l-bits nil))))
403
404;;; Generate the start and end bits for a RLWINM instruction that
405;;; would be equivalent to to LOGANDing the constant with some value.
406;;; Return (VALUES NIL NIL) if the constant contains more than one
407;;; sequence of consecutive 1-bits, else bit indices.
408;;; The caller generally wants to treat the constant as an (UNSIGNED-BYTE 32);
409;;; since this uses LOGCOUNT and INTEGER-LENGTH to find the significant
410;;; bits, it ensures that the constant is a (SIGNED-BYTE 32) that has
411;;; the same least-significant 32 bits.
412(defun x862-mask-bits (constant)
413  (if (< constant 0) (setq constant (logand #xffffffff constant)))
414  (if (= constant #xffffffff)
415    (values 0 31)
416    (if (zerop constant)
417      (values nil nil)
418      (let* ((signed (if (and (logbitp 31 constant)
419                              (> constant 0))
420                       (- constant (ash 1 32))
421                       constant))
422             (count (logcount signed))
423             (len (integer-length signed))
424             (highbit (logbitp (the fixnum (1- len)) constant)))
425        (declare (fixnum count len))
426        (do* ((i 1 (1+ i))
427              (pos (- len 2) (1- pos)))
428             ((= i count)
429              (let* ((start (- 32 len))
430                     (end (+ count start)))
431                (declare (fixnum start end))
432                (if highbit
433                  (values start (the fixnum (1- end)))
434                  (values (logand 31 end)
435                          (the fixnum (1- start))))))
436          (declare (fixnum i pos))
437          (unless (eq (logbitp pos constant) highbit)
438            (return (values nil nil))))))))
439   
440
441(defun x862-ensure-binding-indices-for-vcells (vcells)
442  (dolist (cell vcells)
443    (ensure-binding-index (car cell)))
444  vcells)
445
446(defun x862-register-mask-byte (count)
447  (if (> count 0)
448    (logior
449     (ash 1 (- x8664::save0 8))
450     (if (> count 1)
451       (logior
452        (ash 1 (- x8664::save1 8))
453        (if (> count 2)
454          (logior
455           (ash 1 (- x8664::save2 8))
456           (if (> count 3)
457             (ash 1 (- x8664::save3 8))
458             0))
459          0))
460       0))
461    0))
462
463(defun x862-encode-register-save-ea (ea count)
464  (if (zerop count)
465    0 
466    (min (- (ash ea (- *x862-target-node-shift*)) count) #xff)))
467
468
469(defun x862-compile (afunc &optional lambda-form *x862-record-symbols*)
470  (progn
471    (dolist (a  (afunc-inner-functions afunc))
472      (unless (afunc-lfun a)
473        (x862-compile a 
474                      (if lambda-form 
475                        (afunc-lambdaform a)) 
476                      *x862-record-symbols*))) ; always compile inner guys
477    (let* ((*x862-cur-afunc* afunc)
478           (*x862-returning-values* nil)
479           (*x86-current-context-annotation* nil)
480           (*x862-woi* nil)
481           (*next-lcell-id* -1)
482           (*x862-open-code-inline* nil)
483           (*x862-register-restore-count* nil)
484           (*x862-compiler-register-save-label* nil)
485           (*x862-valid-register-annotations* 0)
486           (*x862-register-ea-annotations* (x862-make-stack 16))
487           (*x862-register-restore-ea* nil)
488           (*x862-constant-alist* nil)
489           (*x862-double-float-constant-alist* nil)
490           (*x862-single-float-constant-alist* nil)
491           (*x862-vstack* 0)
492           (*x862-cstack* 0)
493           (*x86-lap-entry-offset* (target-arch-case
494                                    (:x8632 x8632::fulltag-misc)
495                                    (:x8664 x8664::fulltag-function)))
496           (*x862-result-reg* (target-arch-case
497                               (:x8632 x8632::arg_z)
498                               (:x8664 x8664::arg_z)))
499           (*x862-imm0* (target-arch-case (:x8632 x8632::imm0)
500                                          (:x8664 x8664::imm0)))
501           (*x862-arg-z* (target-arch-case (:x8632 x8632::arg_z)
502                                           (:x8664 x8664::arg_z)))
503           (*x862-arg-y* (target-arch-case (:x8632 x8632::arg_y)
504                                           (:x8664 x8664::arg_y)))
505           (*x862-temp0* (target-arch-case (:x8632 x8632::temp0)
506                                           (:x8664 x8664::temp0)))
507           (*x862-temp1* (target-arch-case (:x8632 x8632::temp1)
508                                           (:x8664 x8664::temp1)))
509           (*x862-fn* (target-arch-case (:x8632 x8632::fn)
510                                        (:x8664 x8664::fn)))
511           (*x862-fname* (target-arch-case (:x8632 x8632::fname)
512                                           (:x8664 x8664::fname)))
513           (*x862-ra0* (target-arch-case (:x8632 x8632::ra0)
514                                         (:x8664 x8664::ra0)))
515           (*x862-allocptr* (target-arch-case (:x8632 x8632::allocptr)
516                                              (:x8664 x8664::allocptr)))
517           (*x862-fp0* (target-arch-case (:x8632 x8632::fp0)
518                                         (:x8664 x8664::fp0)))
519           (*x862-fp1* (target-arch-case (:x8632 x8632::fp1)
520                                         (:x8664 x8664::fp1)))
521           (*x862-target-num-arg-regs* (target-arch-case
522                                        (:x8632 $numx8632argregs)
523                                        (:x8664  $numx8664argregs)))
524           (*x862-target-num-save-regs* (target-arch-case
525                                         (:x8632 $numx8632saveregs)
526                                         (:x8664  $numx8664saveregs)))
527           (*x862-target-lcell-size* (arch::target-lisp-node-size (backend-target-arch *target-backend*)))
528           (*x862-target-fixnum-shift* (arch::target-fixnum-shift (backend-target-arch *target-backend*)))
529           (*x862-target-node-shift* (arch::target-word-shift  (backend-target-arch *target-backend*)))
530           (*x862-target-bits-in-word* (arch::target-nbits-in-word (backend-target-arch *target-backend*)))
531           (*x862-target-node-size* *x862-target-lcell-size*)
532           (*x862-target-half-fixnum-type* `(signed-byte ,(- *x862-target-bits-in-word*
533                                                            (1+ *x862-target-fixnum-shift*))))
534           (*x862-target-dnode-size* (* 2 *x862-target-lcell-size*))
535           (*x862-tos-reg* nil)
536           (*x862-all-lcells* ())
537           (*x862-top-vstack-lcell* nil)
538           (*x862-bottom-vstack-lcell* (x862-new-vstack-lcell :bottom 0 0 nil))
539           (*x862-var-cells* nil)
540           (*backend-vinsns* (backend-p2-vinsn-templates *target-backend*))
541           (*backend-node-regs* (target-arch-case
542                                 (:x8632 x8632-node-regs)
543                                 (:x8664 x8664-node-regs)))
544           (*backend-node-temps* (target-arch-case
545                                  (:x8632 x8632-temp-node-regs)
546                                  (:x8664 x8664-temp-node-regs)))
547           (*available-backend-node-temps* (target-arch-case
548                                            (:x8632 x8632-temp-node-regs)
549                                            (:x8664 x8664-temp-node-regs)))
550           (*backend-imm-temps* (target-arch-case
551                                 (:x8632 x8632-imm-regs)
552                                 (:x8664 x8664-imm-regs)))
553           (*available-backend-imm-temps* (target-arch-case
554                                           (:x8632 x8632-imm-regs)
555                                           (:x8664 x8664-imm-regs)))
556           (*backend-crf-temps* (target-arch-case
557                                 (:x8632 x8632-cr-fields)
558                                 (:x8664 x8664-cr-fields)))
559           (*available-backend-crf-temps* (target-arch-case
560                                           (:x8632 x8632-cr-fields)
561                                           (:x8664 x8664-cr-fields)))
562           (*backend-fp-temps* (target-arch-case
563                                (:x8632 x8632-temp-fp-regs)
564                                (:x8664 x8664-temp-fp-regs)))
565           (*available-backend-fp-temps* (target-arch-case
566                                          (:x8632 x8632-temp-fp-regs)
567                                          (:x8664 x8664-temp-fp-regs)))
568           (bits 0)
569           (*logical-register-counter* -1)
570           (*backend-all-lregs* ())
571           (*x862-popj-labels* nil)
572           (*x862-popreg-labels* nil)
573           (*x862-valret-labels* nil)
574           (*x862-nilret-labels* nil)
575           (*x862-undo-count* 0)
576           (*backend-labels* (x862-make-stack 64 target::subtag-simple-vector))
577           (*x862-undo-stack* (x862-make-stack 64  target::subtag-simple-vector))
578           (*x862-undo-because* (x862-make-stack 64))
579           (*x862-entry-label* nil)
580           (*x862-tail-label* nil)
581           (*x862-tail-vsp* nil)
582           (*x862-tail-nargs* nil)
583           (*x862-inhibit-register-allocation* nil)
584           (*x862-tail-allow* t)
585           (*x862-reckless* nil)
586           (*x862-trust-declarations* t)
587           (*x862-entry-vstack* nil)
588           (*x862-fixed-nargs* nil)
589           (*x862-need-nargs* t)
590           (fname (afunc-name afunc))
591           (*x862-entry-vsp-saved-p* nil)
592           (*x862-vcells* (x862-ensure-binding-indices-for-vcells (afunc-vcells afunc)))
593           (*x862-fcells* (afunc-fcells afunc))
594           *x862-recorded-symbols*)
595      (set-fill-pointer
596       *backend-labels*
597       (set-fill-pointer
598        *x862-undo-stack*
599        (set-fill-pointer 
600         *x862-undo-because*
601         0)))
602      (backend-get-next-label)          ; start @ label 1, 0 is confused with NIL in compound cd
603      (with-dll-node-freelist (vinsns *vinsn-freelist*)
604        (unwind-protect
605             (progn
606               (setq bits (x862-form vinsns (make-wired-lreg *x862-result-reg*) $backend-return (afunc-acode afunc)))
607               (do* ((constants *x862-constant-alist* (cdr constants)))
608                    ((null constants))
609                 (let* ((imm (caar constants)))
610                   (when (x862-symbol-locative-p imm)
611                     (setf (caar constants) (car imm)))))
612               (optimize-vinsns vinsns)
613               (when (logbitp x862-debug-vinsns-bit *x862-debug-mask*)
614                 (format t "~% vinsns for ~s (after generation)" (afunc-name afunc))
615                 (do-dll-nodes (v vinsns) (format t "~&~s" v))
616                 (format t "~%~%"))
617           
618               (with-dll-node-freelist ((frag-list make-frag-list) *frag-freelist*)
619                 (with-dll-node-freelist ((uuo-frag-list make-frag-list) *frag-freelist*)
620                 (let* ((*x86-lap-labels* nil)
621                        (instruction (x86::make-x86-instruction))
622                        (end-code-tag (gensym))
623                        (start-tag (gensym))
624                        (srt-tag (gensym))
625                        debug-info)
626                   (make-x86-lap-label end-code-tag)
627                   (target-arch-case
628                    (:x8664
629                     (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8)
630                                                                 *x86-lap-entry-offset*) -3))
631                     (x86-lap-directive frag-list :byte 0) ;regsave PC
632                     (x86-lap-directive frag-list :byte 0) ;regsave ea
633                     (x86-lap-directive frag-list :byte 0)) ;regsave mask
634                    (:x8632
635                     (make-x86-lap-label start-tag)
636                     (make-x86-lap-label srt-tag)
637                     (x86-lap-directive frag-list :short `(ash (+ (- (:^ ,end-code-tag) 4)
638                                                                  *x86-lap-entry-offset*) -2))
639                     (emit-x86-lap-label frag-list start-tag)))
640                   (x862-expand-vinsns vinsns frag-list instruction uuo-frag-list)
641                   (when (or *x862-double-float-constant-alist*
642                             *x862-single-float-constant-alist*)
643                     (x86-lap-directive frag-list :align 3)
644                     (dolist (double-pair *x862-double-float-constant-alist*)
645                       (destructuring-bind (dfloat . lab) double-pair
646                         (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))
647                         (multiple-value-bind (high low)
648                             (x862-double-float-bits dfloat)
649                           (x86-lap-directive frag-list :long low)
650                           (x86-lap-directive frag-list :long high))))
651                     (dolist (single-pair *x862-single-float-constant-alist*)
652                       (destructuring-bind (sfloat . lab) single-pair
653                         (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))
654                         (let* ((val (single-float-bits sfloat)))
655                           (x86-lap-directive frag-list :long val)))))
656                   (target-arch-case
657                    (:x8632
658                     (x86-lap-directive frag-list :align 2)
659                     ;; start of self reference table
660                     (x86-lap-directive frag-list :long 0)
661                     (emit-x86-lap-label frag-list srt-tag)
662                     ;; make space for self-reference offsets
663                     (do-dll-nodes (frag frag-list)
664                       (dolist (reloc (frag-relocs frag))
665                         (when (eq (reloc-type reloc) :self)
666                           (x86-lap-directive frag-list :long 0))))
667                     (x86-lap-directive frag-list :long x8632::function-boundary-marker))
668                    (:x8664
669                     (x86-lap-directive frag-list :align 3)
670                     (x86-lap-directive frag-list :quad x8664::function-boundary-marker)))
671                   
672                   (emit-x86-lap-label frag-list end-code-tag)
673                   
674                   (dolist (c (reverse *x862-constant-alist*))
675                     (let* ((vinsn-label (cdr c)))
676                       (or (vinsn-label-info vinsn-label)
677                           (setf (vinsn-label-info vinsn-label)
678                                 (find-or-create-x86-lap-label
679                                  vinsn-label)))
680                       (emit-x86-lap-label frag-list vinsn-label)
681                       (target-arch-case
682                        (:x8632
683                         (x86-lap-directive frag-list :long 0))
684                        (:x8664
685                         (x86-lap-directive frag-list :quad 0)))))
686                   
687                   (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc)))
688                     (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
689                   (let* ((function-debugging-info (afunc-lfun-info afunc)))
690                     (when (or function-debugging-info lambda-form *x862-record-symbols*)
691                       (if lambda-form (setq function-debugging-info 
692                                             (list* 'function-lambda-expression lambda-form function-debugging-info)))
693                       (if *x862-record-symbols*
694                         (setq function-debugging-info (nconc (list 'function-symbol-map *x862-recorded-symbols*)
695                                                              function-debugging-info)))
696                       (setq bits (logior (ash 1 $lfbits-symmap-bit) bits))
697                       (setq debug-info function-debugging-info)))
698                   (unless (or fname lambda-form *x862-recorded-symbols*)
699                     (setq bits (logior (ash 1 $lfbits-noname-bit) bits)))
700                   (unless (afunc-parent afunc)
701                     (x862-fixup-fwd-refs afunc))
702                   (setf (afunc-all-vars afunc) nil)
703                   (setf (afunc-argsword afunc) bits)
704                   (let* ((regsave-label (if (typep *x862-compiler-register-save-label* 'vinsn-note)
705                                           (vinsn-label-info (vinsn-note-label *x862-compiler-register-save-label*))))
706                          (regsave-mask (if regsave-label (x862-register-mask-byte
707                                                           *x862-register-restore-count*)))
708                          (regsave-addr (if regsave-label (x862-encode-register-save-ea
709                                                           *x862-register-restore-ea*
710                                                           *x862-register-restore-count*))))
711                     (target-arch-case
712                      (:x8632
713                       (when debug-info
714                         (x86-lap-directive frag-list :long 0))
715                       (when fname
716                         (x86-lap-directive frag-list :long 0))
717                       (x86-lap-directive frag-list :long 0))
718                      (:x8664
719                       (when debug-info
720                         (x86-lap-directive frag-list :quad 0))
721                       (when fname
722                         (x86-lap-directive frag-list :quad 0))
723                       (x86-lap-directive frag-list :quad 0)))
724                     
725                     (relax-frag-list frag-list)
726                     (apply-relocs frag-list)
727                     (fill-for-alignment frag-list)
728                     (target-arch-case
729                      (:x8632
730                       (let* ((label (find-x86-lap-label srt-tag))
731                              (srt-frag (x86-lap-label-frag label))
732                              (srt-index (x86-lap-label-offset label)))
733                         ;; fill in self-reference offsets
734                         (do-dll-nodes (frag frag-list)
735                           (dolist (reloc (frag-relocs frag))
736                             (when (eq (reloc-type reloc) :self)
737                               (setf (frag-ref-32 srt-frag srt-index)
738                                     (+ (frag-address frag) (reloc-pos reloc)))
739                               (incf srt-index 4)))))
740                       ;;(show-frag-bytes frag-list)
741                       ))
742                     
743                     (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr)
744                     (setf (afunc-lfun afunc)
745                           #+x86-target
746                           (if (eq *host-backend* *target-backend*)
747                             (create-x86-function fname frag-list *x862-constant-alist* bits debug-info)
748                             (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info))
749                           #-x86-target
750                           (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info)))
751                   (x862-digest-symbols)))))
752          (backend-remove-labels))))
753    afunc))
754
755
756     
757   
758(defun x862-make-stack (size &optional (subtype target::subtag-s16-vector))
759  (make-uarray-1 subtype size t 0 nil nil nil nil t nil))
760
761(defun x862-fixup-fwd-refs (afunc)
762  (dolist (f (afunc-inner-functions afunc))
763    (x862-fixup-fwd-refs f))
764  (let ((fwd-refs (afunc-fwd-refs afunc)))
765    (when fwd-refs
766      (let* ((native-x86-functions #-x86-target nil
767                                   #+x86-target (eq *target-backend*
768                                                    *host-backend*))
769             (v (if native-x86-functions
770                  (function-to-function-vector (afunc-lfun afunc))
771                  (afunc-lfun afunc)))
772             (vlen (uvsize v)))
773        (declare (fixnum vlen))
774        (dolist (ref fwd-refs)
775          (let* ((ref-fun (afunc-lfun ref)))
776            (do* ((i (if native-x86-functions
777                       (%function-code-words
778                        (function-vector-to-function v))
779                       1)
780                     (1+ i)))
781                 ((= i vlen))
782              (declare (fixnum i))
783              (if (eq (%svref v i) ref)
784                (setf (%svref v i) ref-fun)))))))))
785
786(defun x862-digest-symbols ()
787  (if *x862-recorded-symbols*
788    (let* ((symlist *x862-recorded-symbols*)
789           (len (length symlist))
790           (syms (make-array len))
791           (ptrs (make-array (%i+  (%i+ len len) len)))
792           (i -1)
793           (j -1))
794      (declare (fixnum i j))
795      (dolist (info symlist (progn (%rplaca symlist syms)
796                                   (%rplacd symlist ptrs)))
797        (flet ((label-address (note start-p sym)
798                 (-
799                  (let* ((label (vinsn-note-label note))
800                         (lap-label (if label (vinsn-label-info label))))
801                    (if lap-label
802                      (x86-lap-label-address lap-label)
803                      (compiler-bug "Missing or bad ~s label: ~s" 
804                                    (if start-p 'start 'end) sym)))
805                  (target-arch-case
806                   (:x8632 x8632::fulltag-misc) ;xxx?
807                   (:x8664 x8664::fulltag-function)))))
808          (destructuring-bind (var sym startlab endlab) info
809            (let* ((ea (var-ea var))
810                   (ea-val (ldb (byte 16 0) ea)))
811              (setf (aref ptrs (incf i)) (if (memory-spec-p ea)
812                                           (logior (ash ea-val 6) #o77)
813                                           ea-val)))
814            (setf (aref syms (incf j)) sym)
815            (setf (aref ptrs (incf i)) (label-address startlab t sym))
816            (setf (aref ptrs (incf i)) (label-address endlab nil sym))))))))
817
818(defun x862-decls (decls)
819  (if (fixnump decls)
820    (locally (declare (fixnum decls))
821      (setq *x862-tail-allow* (neq 0 (%ilogand2 $decl_tailcalls decls))
822            *x862-open-code-inline* (neq 0 (%ilogand2 $decl_opencodeinline decls))
823            *x862-reckless* (neq 0 (%ilogand2 $decl_unsafe decls))
824            *x862-trust-declarations* (neq 0 (%ilogand2 $decl_trustdecls decls))))))
825
826
827(defun %x862-bigger-cdr-than (x y)
828  (declare (cons x y))
829  (> (the fixnum (cdr x)) (the fixnum (cdr y))))
830
831;;; Return an unordered list of "varsets": each var in a varset can be
832;;; assigned a register and all vars in a varset can be assigned the
833;;; same register (e.g., no scope conflicts.)
834
835(defun x862-partition-vars (vars)
836  (labels ((var-weight (var)
837             (let* ((bits (nx-var-bits var)))
838               (declare (fixnum bits))
839               (if (eql 0 (logand bits (logior
840                                        (ash 1 $vbitpuntable)
841                                        (ash -1 $vbitspecial)
842                                        (ash 1 $vbitnoreg))))
843                 (if (eql (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))
844                          (logand bits (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))))
845                   0
846                   (%i+ (%ilogand $vrefmask bits) (%ilsr 8 (%ilogand $vsetqmask bits))))
847                 0)))
848           (sum-weights (varlist) 
849             (let ((sum 0))
850               (dolist (v varlist sum) (incf sum (var-weight v)))))
851           (vars-disjoint-p (v1 v2)
852             (if (eq v1 v2)
853               nil
854               (if (memq v1 (var-binding-info v2))
855                 nil
856                 (if (memq v2 (var-binding-info v1))
857                   nil
858                   t)))))
859    (setq vars (%sort-list-no-key
860                ;(delete-if #'(lambda (v) (eql (var-weight v) 0)) vars)
861                (do* ((handle (cons nil vars))
862                      (splice handle))
863                     ((null (cdr splice)) (cdr handle))                 
864                  (declare (dynamic-extent handle) (type cons handle splice))
865                  (if (eql 0 (var-weight (%car (cdr splice))))
866                    (rplacd splice (%cdr (cdr splice)))
867                    (setq splice (cdr splice))))
868                #'(lambda (v1 v2) (%i> (var-weight v1) (var-weight v2)))))
869    ;; This isn't optimal.  It partitions all register-allocatable
870    ;; variables into sets such that
871    ;; 1) no variable is a member of more than one set and
872    ;; 2) all variables in a given set are disjoint from each other
873    ;; A set might have exactly one member.
874    ;; If a register is allocated for any member of a set, it's
875    ;; allocated for all members of that set.
876    (let* ((varsets nil))
877      (do* ((all vars (cdr all)))
878           ((null all))
879        (let* ((var (car all)))
880          (when (dolist (already varsets t)
881                  (when (memq var (car already)) (return)))
882            (let* ((varset (cons var nil)))
883              (dolist (v (cdr all))
884                (when (dolist (already varsets t)
885                        (when (memq v (car already)) (return)))
886                  (when (dolist (d varset t)
887                          (unless (vars-disjoint-p v d) (return)))
888                    (push v varset))))
889              (let* ((weight (sum-weights varset)))
890                (declare (fixnum weight))
891                (if (>= weight 3)
892                  (push (cons (nreverse varset) weight) varsets)))))))
893      varsets)))
894
895;;; Maybe globally allocate registers to symbols naming functions & variables,
896;;; and to simple lexical variables.
897(defun x862-allocate-global-registers (fcells vcells all-vars no-regs)
898  (if (or no-regs (target-arch-case (:x8632 t)))
899    (progn
900      (dolist (c fcells) (%rplacd c nil))
901      (dolist (c vcells) (%rplacd c nil))
902      (values 0 nil))
903    (let* ((maybe (x862-partition-vars all-vars)))
904      (dolist (c fcells) 
905        (if (>= (the fixnum (cdr c)) 3) (push c maybe)))
906      (dolist (c vcells) 
907        (if (>= (the fixnum (cdr c)) 3) (push c maybe)))
908      (do* ((things (%sort-list-no-key maybe #'%x862-bigger-cdr-than) (cdr things))
909            (n 0 (1+ n))
910            (registers (target-arch-case 
911                        (:x8632 (error "no nvrs on x8632"))
912                        (:x8664
913                         (list x8664::save0 x8664::save1 x8664::save2 x8664::save3))))
914            (regno (pop registers) (pop registers))
915            (constant-alist ()))
916           ((or (null things) (= n *x862-target-num-save-regs*))
917            (dolist (cell fcells) (%rplacd cell nil))
918            (dolist (cell vcells) (%rplacd cell nil))
919            (values n constant-alist))
920        (declare (list things)
921                 (fixnum n regno))
922        (let* ((thing (car things)))
923          (if (or (memq thing fcells)
924                  (memq thing vcells))
925            (push (cons thing regno) constant-alist)
926            (dolist (var (car thing))
927              (nx-set-var-bits var 
928                               (%ilogior (%ilogand (%ilognot $vrefmask) (nx-var-bits var))
929                                 regno
930                                 (%ilsl $vbitreg 1))))))))))
931
932
933   
934;;; Vpush the last N non-volatile-registers.
935(defun x862-save-nvrs (seg n)
936  (declare (fixnum n))
937  (target-arch-case
938   ;; no nvrs on x8632
939   (:x8664
940    (when (> n 0)
941      (setq *x862-compiler-register-save-label* (x862-emit-note seg :regsave))
942      (with-x86-local-vinsn-macros (seg)
943        (let* ((mask x8664-nonvolatile-node-regs))
944          (dotimes (i n)
945            (let* ((reg (1- (integer-length mask))))
946              (x862-vpush-register seg reg :regsave reg 0)
947              (setq mask (logandc2 mask (ash 1 reg)))))))
948      (setq *x862-register-restore-ea* *x862-vstack*
949            *x862-register-restore-count* n)))))
950
951
952;;; If there are an indefinite number of args/values on the vstack,
953;;; we have to restore from a register that matches the compiler's
954;;; notion of the vstack depth.  This can be computed by the caller
955;;; (sum of vsp & nargs, or copy of vsp  before indefinite number of
956;;; args pushed, etc.)
957
958
959(defun x862-restore-nvrs (seg ea nregs &optional (can-pop t))
960  (target-arch-case
961   ;; no nvrs on x8632
962   (:x8664
963    (when (and ea nregs)
964      (with-x86-local-vinsn-macros (seg)
965        (let* ((mask x8664-nonvolatile-node-regs)
966               (regs ()))
967          (dotimes (i nregs)
968            (let* ((reg (1- (integer-length mask))))
969              (push reg regs)
970              (setq mask (logandc2 mask (ash 1 reg)))))
971          (cond (can-pop
972                 (let* ((diff-in-bytes (- *x862-vstack* ea)))
973                   (unless (zerop diff-in-bytes)
974                     (x862-adjust-vstack diff-in-bytes)
975                     (! vstack-discard (floor diff-in-bytes *x862-target-node-size*)))
976                   (dolist (reg regs)
977                     (! vpop-register reg))))
978                (t
979                 (dolist (reg regs)
980                   (! vframe-load reg (- ea *x862-target-node-size*) ea)
981                   (decf ea *x862-target-node-size*))))))))))
982
983
984(defun x862-bind-lambda (seg lcells req opt rest keys auxen optsupvloc passed-in-regs lexpr &optional inherited
985                             &aux (vloc 0) (numopt (list-length (%car opt)))
986                             (nkeys (list-length (%cadr keys))) 
987                             reg)
988  (declare (fixnum vloc))
989  (x862-check-lcell-depth)
990  (dolist (arg inherited)
991    (if (memq arg passed-in-regs)
992      (x862-set-var-ea seg arg (var-ea arg))
993      (let* ((lcell (pop lcells)))
994        (if (setq reg (x862-assign-register-var arg))
995          (x862-init-regvar seg arg reg (x862-vloc-ea vloc))
996          (x862-bind-var seg arg vloc lcell))
997        (setq vloc (%i+ vloc *x862-target-node-size*)))))
998  (dolist (arg req)
999    (if (memq arg passed-in-regs)
1000      (x862-set-var-ea seg arg (var-ea arg))
1001      (let* ((lcell (pop lcells)))
1002        (if (setq reg (x862-assign-register-var arg))
1003          (x862-init-regvar seg arg reg (x862-vloc-ea vloc))
1004          (x862-bind-var seg arg vloc lcell))
1005        (setq vloc (%i+ vloc *x862-target-node-size*)))))
1006  (when opt
1007    (if (x862-hard-opt-p opt)
1008      (setq vloc (apply #'x862-initopt seg vloc optsupvloc lcells (nthcdr (- (length lcells) numopt) lcells) opt)
1009            lcells (nthcdr numopt lcells))
1010
1011      (dolist (var (%car opt))
1012        (if (memq var passed-in-regs)
1013          (x862-set-var-ea seg var (var-ea var))
1014          (let* ((lcell (pop lcells)))
1015            (if (setq reg (x862-assign-register-var var))
1016              (x862-init-regvar seg var reg (x862-vloc-ea vloc))
1017              (x862-bind-var seg var vloc lcell))
1018            (setq vloc (+ vloc *x862-target-node-size*)))))))
1019
1020  (when rest
1021    (if lexpr
1022      (progn
1023        (if (setq reg (x862-assign-register-var rest))
1024          (progn
1025            (x862-copy-register seg reg *x862-arg-z*)
1026            (x862-set-var-ea seg rest reg))
1027            (let* ((loc *x862-vstack*))
1028              (x862-vpush-register seg *x862-arg-z* :reserved)
1029              (x862-note-top-cell rest)
1030              (x862-bind-var seg rest loc *x862-top-vstack-lcell*))))
1031      (let* ((rvloc (+ vloc (* 2 *x862-target-node-size* nkeys))))
1032        (if (setq reg (x862-assign-register-var rest))
1033          (x862-init-regvar seg rest reg (x862-vloc-ea rvloc))
1034          (x862-bind-var seg rest rvloc (pop lcells))))))
1035    (when keys
1036      (apply #'x862-init-keys seg vloc lcells keys))
1037  (x862-seq-bind seg (%car auxen) (%cadr auxen)))
1038
1039
1040(defun x862-initopt (seg vloc spvloc lcells splcells vars inits spvars)
1041  (with-x86-local-vinsn-macros (seg)
1042    (dolist (var vars vloc)
1043      (let* ((initform (pop inits))
1044             (spvar (pop spvars))
1045             (lcell (pop lcells))
1046             (splcell (pop splcells))
1047             (reg (x862-assign-register-var var))
1048             (regloadedlabel (if reg (backend-get-next-label))))
1049        (unless (nx-null initform)
1050          (let ((skipinitlabel (backend-get-next-label)))
1051            (with-crf-target () crf
1052              (x862-compare-ea-to-nil seg crf (x862-make-compound-cd 0 skipinitlabel) (x862-vloc-ea spvloc)  x86::x86-e-bits t))
1053            (if reg
1054              (x862-form seg reg regloadedlabel initform)
1055              (x862-register-to-stack seg (x862-one-untargeted-reg-form seg initform ($ *x862-arg-z*)) (x862-vloc-ea vloc)))
1056            (@ skipinitlabel)))
1057        (if reg
1058          (progn
1059            (x862-init-regvar seg var reg (x862-vloc-ea vloc))
1060            (@ regloadedlabel))
1061          (x862-bind-var seg var vloc lcell))
1062        (when spvar
1063          (if (setq reg (x862-assign-register-var spvar))
1064            (x862-init-regvar seg spvar reg (x862-vloc-ea spvloc))
1065            (x862-bind-var seg spvar spvloc splcell))))
1066      (setq vloc (%i+ vloc *x862-target-node-size*))
1067      (if spvloc (setq spvloc (%i+ spvloc *x862-target-node-size*))))))
1068
1069(defun x862-init-keys (seg vloc lcells allow-others keyvars keysupp keyinits keykeys)
1070  (declare (ignore keykeys allow-others))
1071  (with-x86-local-vinsn-macros (seg)
1072    (dolist (var keyvars)
1073      (let* ((spvar (pop keysupp))
1074             (initform (pop keyinits))
1075             (reg (x862-assign-register-var var))
1076             (regloadedlabel (if reg (backend-get-next-label)))
1077             (var-lcell (pop lcells))
1078             (sp-lcell (pop lcells))
1079             (sploc (%i+ vloc *x862-target-node-size*)))
1080        (unless (nx-null initform)
1081          (let ((skipinitlabel (backend-get-next-label)))
1082            (with-crf-target () crf
1083              (x862-compare-ea-to-nil seg crf (x862-make-compound-cd 0 skipinitlabel) (x862-vloc-ea sploc)  x86::x86-e-bits t))
1084            (if reg
1085              (x862-form seg reg regloadedlabel initform)
1086              (x862-register-to-stack seg (x862-one-untargeted-reg-form seg initform ($ *x862-arg-z*)) (x862-vloc-ea vloc)))
1087            (@ skipinitlabel)))
1088        (if reg
1089          (progn
1090            (x862-init-regvar seg var reg (x862-vloc-ea vloc))
1091            (@ regloadedlabel))
1092          (x862-bind-var seg var vloc var-lcell))
1093        (when spvar
1094          (if (setq reg (x862-assign-register-var spvar))
1095            (x862-init-regvar seg spvar reg (x862-vloc-ea sploc))
1096            (x862-bind-var seg spvar sploc sp-lcell))))
1097      (setq vloc (%i+ vloc (* 2 *x862-target-node-size*))))))
1098
1099;;; Vpush register r, unless var gets a globally-assigned register.
1100;;; Return NIL if register was vpushed, else var.
1101(defun x862-vpush-arg-register (seg reg var)
1102  (when var
1103    (let* ((bits (nx-var-bits var)))
1104      (declare (fixnum bits))
1105      (if (logbitp $vbitreg bits)
1106        var
1107        (progn 
1108          (x862-vpush-register seg reg :reserved)
1109          nil)))))
1110
1111
1112;;; nargs has been validated, arguments defaulted and canonicalized.
1113;;; Save caller's context, then vpush any argument registers that
1114;;; didn't get global registers assigned to their variables.
1115;;; Return a list of vars/nils for each argument register
1116;;;  (nil if vpushed, var if still in arg_reg).
1117(defun x862-argregs-entry (seg revargs &optional variable-args-entry)
1118  (with-x86-local-vinsn-macros (seg)
1119    (let* ((nargs (length revargs))
1120           (reg-vars ()))
1121      (declare (type (unsigned-byte 16) nargs))
1122      (unless variable-args-entry
1123        (if (<= nargs *x862-target-num-arg-regs*) ; caller didn't vpush anything
1124          (! save-lisp-context-no-stack-args)
1125          (let* ((offset (* (the fixnum (- nargs *x862-target-num-arg-regs*)) *x862-target-node-size*)))
1126            (declare (fixnum offset))
1127            (! save-lisp-context-offset offset))))
1128      (target-arch-case
1129       (:x8632
1130        (destructuring-bind (&optional zvar yvar &rest stack-args) revargs
1131          (let* ((nstackargs (length stack-args)))
1132            (x862-set-vstack (* nstackargs *x862-target-node-size*))
1133            (dotimes (i nstackargs)
1134              (x862-new-vstack-lcell :reserved *x862-target-lcell-size* 0 nil))
1135            (if (>= nargs 2)
1136              (push (x862-vpush-arg-register seg ($ *x862-arg-y*) yvar) reg-vars))
1137            (if (>= nargs 1)
1138              (push (x862-vpush-arg-register seg ($ *x862-arg-z*) zvar) reg-vars)))))
1139       (:x8664
1140        (destructuring-bind (&optional zvar yvar xvar &rest stack-args) revargs
1141          (let* ((nstackargs (length stack-args)))
1142            (x862-set-vstack (* nstackargs *x862-target-node-size*))
1143            (dotimes (i nstackargs)
1144              (x862-new-vstack-lcell :reserved *x862-target-lcell-size* 0 nil))
1145            (if (>= nargs 3)
1146              (push (x862-vpush-arg-register seg ($ x8664::arg_x) xvar) reg-vars))
1147            (if (>= nargs 2)
1148              (push (x862-vpush-arg-register seg ($ *x862-arg-y*) yvar) reg-vars))
1149            (if (>= nargs 1)
1150              (push (x862-vpush-arg-register seg ($ *x862-arg-z*) zvar) reg-vars))))))
1151      reg-vars)))
1152
1153;;; Just required args.
1154;;; Since this is just a stupid bootstrapping port, always save
1155;;; lisp context.
1156(defun x862-req-nargs-entry (seg rev-fixed-args)
1157  (let* ((nargs (length rev-fixed-args)))
1158    (declare (type (unsigned-byte 16) nargs))
1159    (with-x86-local-vinsn-macros (seg)
1160      (unless *x862-reckless*
1161        (! check-exact-nargs nargs))
1162      (x862-argregs-entry seg rev-fixed-args))))
1163
1164;;; No more &optional args than register args; all &optionals default
1165;;; to NIL and none have supplied-p vars.  No &key/&rest.
1166(defun x862-simple-opt-entry (seg rev-opt-args rev-req-args)
1167  (let* ((min (length rev-req-args))
1168         (nopt (length rev-opt-args))
1169         (max (+ min nopt)))
1170    (declare (type (unsigned-byte 16) min nopt max))
1171    (with-x86-local-vinsn-macros (seg)
1172      (unless *x862-reckless*
1173        (if rev-req-args
1174          (! check-min-max-nargs min max)
1175          (! check-max-nargs max)))
1176      (if (> min *x862-target-num-arg-regs*)
1177        (! save-lisp-context-in-frame)
1178        (if (<= max *x862-target-num-arg-regs*)
1179          (! save-lisp-context-no-stack-args)
1180          (! save-lisp-context-variable-arg-count)))
1181      (if (= nopt 1)
1182        (! default-1-arg min)
1183        (if (= nopt 2)
1184          (! default-2-args min)
1185          (! default-3-args min)))
1186      (x862-argregs-entry seg (append rev-opt-args rev-req-args) t))))
1187
1188;;; if "num-fixed" is > 0, we've already ensured that at least that many args
1189;;; were provided; that may enable us to generate better code for saving the
1190;;; argument registers.
1191;;; We're responsible for computing the caller's VSP and saving
1192;;; caller's state.
1193(defun x862-lexpr-entry (seg num-fixed)
1194  (with-x86-local-vinsn-macros (seg)
1195    (! save-lexpr-argregs num-fixed)
1196    ;; The "lexpr" (address of saved nargs register, basically
1197    ;; is now in arg_z
1198    (! build-lexpr-frame)
1199    (dotimes (i num-fixed)
1200      (! copy-lexpr-argument (- num-fixed i)))))
1201
1202
1203(defun x862-structured-initopt (seg lcells vloc context vars inits spvars)
1204  (with-x86-local-vinsn-macros (seg)
1205    (dolist (var vars vloc)
1206      (let* ((initform (pop inits))
1207             (spvar (pop spvars))
1208             (spvloc (%i+ vloc *x862-target-node-size*))
1209             (var-lcell (pop lcells))
1210             (sp-lcell (pop lcells)))
1211        (unless (nx-null initform)
1212          (let ((skipinitlabel (backend-get-next-label)))
1213            (with-crf-target () crf
1214              (x862-compare-ea-to-nil seg crf (x862-make-compound-cd 0 skipinitlabel) (x862-vloc-ea spvloc) x86::x86-e-bits t))
1215            (x862-register-to-stack seg (x862-one-untargeted-reg-form seg initform ($ *x862-arg-z*)) (x862-vloc-ea vloc))
1216            (@ skipinitlabel)))
1217        (x862-bind-structured-var seg var vloc var-lcell context)
1218        (when spvar
1219          (x862-bind-var seg spvar spvloc sp-lcell)))
1220      (setq vloc (%i+ vloc (* 2 *x862-target-node-size*))))))
1221
1222
1223
1224(defun x862-structured-init-keys (seg lcells vloc context allow-others keyvars keysupp keyinits keykeys)
1225  (declare (ignore keykeys allow-others))
1226  (with-x86-local-vinsn-macros (seg)
1227    (dolist (var keyvars)
1228      (let* ((spvar (pop keysupp))
1229             (initform (pop keyinits))
1230             (sploc (%i+ vloc *x862-target-node-size*))
1231             (var-lcell (pop lcells))
1232             (sp-reg ($ *x862-arg-z*))
1233             (sp-lcell (pop lcells)))
1234        (unless (nx-null initform)
1235          (x862-stack-to-register seg (x862-vloc-ea sploc) sp-reg)
1236          (let ((skipinitlabel (backend-get-next-label)))
1237            (with-crf-target () crf
1238              (x862-compare-register-to-nil seg crf (x862-make-compound-cd 0 skipinitlabel) sp-reg x86::x86-e-bits t))
1239            (x862-register-to-stack seg (x862-one-untargeted-reg-form seg initform ($ *x862-arg-z*)) (x862-vloc-ea vloc))
1240            (@ skipinitlabel)))
1241        (x862-bind-structured-var seg var vloc var-lcell context)
1242        (when spvar
1243          (x862-bind-var seg spvar sploc sp-lcell)))
1244      (setq vloc (%i+ vloc (* 2 *x862-target-node-size*))))))
1245
1246(defun x862-vloc-ea (n &optional vcell-p)
1247  (setq n (make-memory-spec (dpb memspec-frame-address memspec-type-byte n)))
1248  (if vcell-p
1249    (make-vcell-memory-spec n)
1250    n))
1251
1252
1253(defun x862-form (seg vreg xfer form)
1254  (if (nx-null form)
1255    (x862-nil seg vreg xfer)
1256    (if (nx-t form)
1257      (x862-t seg vreg xfer)
1258      (let* ((op nil)
1259             (fn nil))
1260        (if (and (consp form)
1261                 (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
1262          (if (and (null vreg)
1263                   (%ilogbitp operator-acode-subforms-bit op)
1264                   (%ilogbitp operator-assignment-free-bit op))
1265            (dolist (f (%cdr form) (x862-branch seg xfer))
1266              (x862-form seg nil nil f ))
1267            (apply fn seg vreg xfer (%cdr form)))
1268          (compiler-bug "x862-form ? ~s" form))))))
1269
1270;;; dest is a float reg - form is acode
1271(defun x862-form-float (seg freg xfer form)
1272  (declare (ignore xfer))
1273  (when (or (nx-null form)(nx-t form))(compiler-bug "x862-form to freg ~s" form))
1274  (when (and (= (get-regspec-mode freg) hard-reg-class-fpr-mode-double)
1275             (x862-form-typep form 'double-float))
1276    ;; kind of screwy - encoding the source type in the dest register spec
1277    (set-node-regspec-type-modes freg hard-reg-class-fpr-type-double))
1278  (let* ((fn nil))
1279    (if (and (consp form)
1280             (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (acode-operator form)))))     
1281      (apply fn seg freg nil (%cdr form))
1282      (compiler-bug "x862-form ? ~s" form))))
1283
1284
1285
1286(defun x862-form-typep (form type)
1287  (acode-form-typep form type *x862-trust-declarations*)
1288)
1289
1290(defun x862-form-type (form)
1291  (acode-form-type form *x862-trust-declarations*))
1292 
1293(defun x862-use-operator (op seg vreg xfer &rest forms)
1294  (declare (dynamic-extent forms))
1295  (apply (svref *x862-specials* (%ilogand operator-id-mask op)) seg vreg xfer forms))
1296
1297;;; Returns true iff lexical variable VAR isn't setq'ed in FORM.
1298;;; Punts a lot ...
1299(defun x862-var-not-set-by-form-p (var form)
1300  (or (not (%ilogbitp $vbitsetq (nx-var-bits var)))
1301      (x862-setqed-var-not-set-by-form-p var form)))
1302
1303(defun x862-setqed-var-not-set-by-form-p (var form)
1304  (setq form (acode-unwrapped-form form))
1305  (or (atom form)
1306      (x86-constant-form-p form)
1307      (x862-lexical-reference-p form)
1308      (let ((op (acode-operator form))
1309            (subforms nil))
1310        (if (eq op (%nx1-operator setq-lexical))
1311          (and (neq var (cadr form))
1312               (x862-setqed-var-not-set-by-form-p var (caddr form)))
1313          (and (%ilogbitp operator-side-effect-free-bit op)
1314               (flet ((not-set-in-formlist (formlist)
1315                        (dolist (subform formlist t)
1316                          (unless (x862-setqed-var-not-set-by-form-p var subform) (return)))))
1317                 (if
1318                   (cond ((%ilogbitp operator-acode-subforms-bit op) (setq subforms (%cdr form)))
1319                         ((%ilogbitp operator-acode-list-bit op) (setq subforms (cadr form))))
1320                   (not-set-in-formlist subforms)
1321                   (and (or (eq op (%nx1-operator call))
1322                            (eq op (%nx1-operator lexical-function-call)))
1323                        (x862-setqed-var-not-set-by-form-p var (cadr form))
1324                        (setq subforms (caddr form))
1325                        (not-set-in-formlist (car subforms))
1326                        (not-set-in-formlist (cadr subforms))))))))))
1327
1328(defun x862-check-fixnum-overflow (seg target &optional labelno)
1329  (with-x86-local-vinsn-macros (seg)
1330    (if *x862-open-code-inline*
1331      (let* ((no-overflow (backend-get-next-label)))
1332        (! set-bigits-and-header-for-fixnum-overflow target (aref *backend-labels* (or labelno no-overflow)))
1333        (! %allocate-uvector target)
1334        (! set-bigits-after-fixnum-overflow target)
1335        (when labelno
1336          (-> labelno))
1337        (@ no-overflow))
1338      (if labelno
1339        (! fix-fixnum-overflow-ool-and-branch target (aref *backend-labels* labelno))
1340        (! fix-fixnum-overflow-ool target)))))
1341
1342(defun x862-nil (seg vreg xfer)
1343  (with-x86-local-vinsn-macros (seg vreg xfer)
1344    (if (eq vreg :push)
1345      (progn
1346        (! vpush-fixnum (target-arch-case
1347                         (:x8632 x8632::nil-value)
1348                         (:x8664 x8664::nil-value)))
1349        (^))
1350      (progn
1351        (if (x862-for-value-p vreg)
1352          (ensuring-node-target (target vreg)
1353            (! load-nil target)))
1354        (x862-branch seg (x862-cd-false xfer))))))
1355
1356(defun x862-t (seg vreg xfer)
1357  (with-x86-local-vinsn-macros (seg vreg xfer)
1358    (if (eq vreg :push)
1359      (progn
1360        (! vpush-fixnum (target-arch-case
1361                         (:x8632 x8632::t-value)
1362                         (:x8664 x8664::t-value)))
1363        (^))
1364      (progn
1365        (if (x862-for-value-p vreg)
1366          (ensuring-node-target (target vreg)
1367            (! load-t target)))
1368        (x862-branch seg (x862-cd-true xfer))))))
1369
1370(defun x862-for-value-p (vreg)
1371  (and vreg (not (backend-crf-p vreg))))
1372
1373(defun x862-mvpass (seg form &optional xfer)
1374  (with-x86-local-vinsn-macros (seg)
1375    (x862-form seg  ($ *x862-arg-z*) (logior (or xfer 0) $backend-mvpass-mask) form)))
1376
1377(defun x862-adjust-vstack (delta)
1378  (x862-set-vstack (%i+ *x862-vstack* delta)))
1379
1380(defun x862-set-vstack (new)
1381  (setq *x862-vstack* new))
1382
1383
1384;;; Emit a note at the end of the segment.
1385(defun x862-emit-note (seg class &rest info)
1386  (declare (dynamic-extent info))
1387  (let* ((note (make-vinsn-note class info)))
1388    (append-dll-node (vinsn-note-label note) seg)
1389    note))
1390
1391;;; Emit a note immediately before the target vinsn.
1392(defun x86-prepend-note (vinsn class &rest info)
1393  (declare (dynamic-extent info))
1394  (let* ((note (make-vinsn-note class info)))
1395    (insert-dll-node-before (vinsn-note-label note) vinsn)
1396    note))
1397
1398(defun x862-close-note (seg note)
1399  (let* ((end (close-vinsn-note note)))
1400    (append-dll-node (vinsn-note-label end) seg)
1401    end))
1402
1403
1404
1405
1406
1407
1408(defun x862-stack-to-register (seg memspec reg)
1409  (with-x86-local-vinsn-macros (seg)
1410    (let* ((offset (memspec-frame-address-offset memspec)))
1411      (if (and *x862-tos-reg*
1412               (= offset (- *x862-vstack* *x862-target-node-size*)))
1413        (x862-copy-register seg reg *x862-tos-reg*)
1414        (! vframe-load reg offset  *x862-vstack*)))))
1415
1416(defun x862-lcell-to-register (seg lcell reg)
1417  (with-x86-local-vinsn-macros (seg)
1418    (! lcell-load reg lcell (x862-vstack-mark-top))))
1419
1420(defun x862-register-to-lcell (seg reg lcell)
1421  (with-x86-local-vinsn-macros (seg)
1422    (! lcell-store reg lcell (x862-vstack-mark-top))))
1423
1424(defun x862-register-to-stack (seg reg memspec)
1425  (with-x86-local-vinsn-macros (seg)
1426    (! vframe-store reg (memspec-frame-address-offset memspec) *x862-vstack*)))
1427
1428
1429(defun x862-ea-open (ea)
1430  (if (and ea (not (typep ea 'lreg)) (addrspec-vcell-p ea))
1431    (make-memory-spec (memspec-frame-address-offset ea))
1432    ea))
1433
1434(defun x862-set-NARGS (seg n)
1435  (if (> n call-arguments-limit)
1436    (error "~s exceeded." call-arguments-limit)
1437    (with-x86-local-vinsn-macros (seg)
1438      (! set-nargs n))))
1439
1440(defun x862-assign-register-var (v)
1441  (let ((bits (nx-var-bits v)))
1442    (when (%ilogbitp $vbitreg bits)
1443      (%ilogand bits $vrefmask))))
1444
1445(defun x862-single-float-bits (the-sf)
1446  (single-float-bits the-sf))
1447
1448(defun x862-double-float-bits (the-df)
1449  (double-float-bits the-df))
1450
1451(defun x862-push-immediate (seg xfer form)
1452  (with-x86-local-vinsn-macros (seg)
1453    (if (typep form 'character)
1454      (! vpush-fixnum (logior (ash (char-code form) 8)
1455                              (arch::target-subtag-char (backend-target-arch *target-backend*))))
1456      (let* ((reg (x862-register-constant-p form)))
1457        (if reg
1458          (! vpush-register reg)
1459          (let* ((lab (x86-immediate-label form)))
1460            (! vpush-constant lab)))))
1461    (x862-branch seg xfer)))
1462
1463     
1464(pushnew (%nx1-operator immediate) *x862-operator-supports-push*) 
1465(defun x862-immediate (seg vreg xfer form)
1466  (if (eq vreg :push)
1467    (x862-push-immediate seg xfer form)
1468    (with-x86-local-vinsn-macros (seg vreg xfer)
1469      (if vreg
1470        (if (and (= (hard-regspec-class vreg) hard-reg-class-fpr)
1471                 (or (and (typep form 'double-float) (= (get-regspec-mode vreg) hard-reg-class-fpr-mode-double))
1472                     (and (typep form 'short-float)(= (get-regspec-mode vreg) hard-reg-class-fpr-mode-single))))
1473          (if (zerop form)
1474            (if (eql form 0.0d0)
1475              (! zero-double-float-register vreg)
1476              (! zero-single-float-register vreg))
1477            (if (typep form 'short-float)
1478              (let* ((lab (x86-single-float-constant-label form)))
1479                (! load-single-float-constant vreg lab))
1480              (let* ((lab (x86-double-float-constant-label form)))
1481                (! load-double-float-constant vreg lab))))
1482          (target-arch-case
1483           (:x8632
1484            (if (and (= (hard-regspec-class vreg) hard-reg-class-gpr)
1485                     (member (get-regspec-mode vreg)
1486                             '(hard-reg-class-gpr-mode-u32
1487                               hard-reg-class-gpr-mode-s32
1488                               hard-reg-class-gpr-mode-address))
1489                     (or (typep form '(unsigned-byte 32))
1490                         (typep form '(signed-byte 32))))
1491              ;; The bits fit.  Get them in the register somehow.
1492              (if (typep form '(signed-byte 32))
1493                (x862-lri seg vreg form)
1494                (x862-lriu seg vreg form))
1495              (ensuring-node-target (target vreg)
1496                (if (characterp form)
1497                  (! load-character-constant target (char-code form))
1498                  (x862-store-immediate seg form target)))))
1499           (:x8664
1500            (if (and (typep form '(unsigned-byte 32))
1501                     (= (hard-regspec-class vreg) hard-reg-class-gpr)
1502                     (= (get-regspec-mode vreg)
1503                        hard-reg-class-gpr-mode-u32))
1504              (x862-lri seg vreg form)
1505              (ensuring-node-target
1506                  (target vreg)
1507                (if (characterp form)
1508                  (! load-character-constant target (char-code form))
1509                  (x862-store-immediate seg form target)))))))
1510        (if (and (listp form) *load-time-eval-token* (eq (car form) *load-time-eval-token*))
1511          (x862-store-immediate seg form ($ *x862-temp0*))))
1512      (^))))
1513
1514(defun x862-register-constant-p (form)
1515  (and (consp form)
1516           (or (memq form *x862-vcells*)
1517               (memq form *x862-fcells*))
1518           (%cdr form)))
1519
1520(defun x862-store-immediate (seg imm dest)
1521  (with-x86-local-vinsn-macros (seg)
1522    (let* ((reg (x862-register-constant-p imm)))
1523      (if reg
1524        (x862-copy-register seg dest reg)
1525        (let* ((lab (x86-immediate-label imm)))
1526          (! ref-constant dest lab)))
1527      dest)))
1528
1529
1530;;; Returns label iff form is (local-go <tag>) and can go without adjusting stack.
1531(defun x862-go-label (form)
1532  (let ((current-stack (x862-encode-stack)))
1533    (while (and (acode-p form) (or (eq (acode-operator form) (%nx1-operator progn))
1534                                   (eq (acode-operator form) (%nx1-operator local-tagbody))))
1535      (setq form (caadr form)))
1536    (when (acode-p form)
1537      (let ((op (acode-operator form)))
1538        (if (and (eq op (%nx1-operator local-go))
1539                 (x862-equal-encodings-p (%caddr (%cadr form)) current-stack))
1540          (%cadr (%cadr form))
1541          (if (and (eq op (%nx1-operator local-return-from))
1542                   (nx-null (caddr form)))
1543            (let ((tagdata (car (cadr form))))
1544              (and (x862-equal-encodings-p (cdr tagdata) current-stack)
1545                   (null (caar tagdata))
1546                   (< 0 (cdar tagdata) $backend-mvpass)
1547                   (cdar tagdata)))))))))
1548
1549(defun x862-single-valued-form-p (form)
1550  (setq form (acode-unwrapped-form form))
1551  (or (nx-null form)
1552      (nx-t form)
1553      (if (acode-p form)
1554        (let ((op (acode-operator form)))
1555          (or (%ilogbitp operator-single-valued-bit op)
1556              (and (eql op (%nx1-operator values))
1557                   (let ((values (cadr form)))
1558                     (and values (null (cdr values)))))
1559              nil                       ; Learn about functions someday
1560              )))))
1561
1562(defun x862-box-s32 (seg node-dest s32-src)
1563  (with-x86-local-vinsn-macros (seg)
1564    (if (target-arch-case
1565         (:x8632 nil)
1566         (:x8664 t))
1567      (! box-fixnum node-dest s32-src)
1568      (let* ((arg_z ($ *x862-arg-z*))
1569             (imm0 ($ *x862-imm0* :mode :s32)))
1570        (x862-copy-register seg imm0 s32-src)
1571        (! call-subprim (subprim-name->offset '.SPmakes32))
1572        (x862-copy-register seg node-dest arg_z)))))
1573
1574(defun x862-box-s64 (seg node-dest s64-src)
1575  (with-x86-local-vinsn-macros (seg)
1576    (if (target-arch-case
1577         (:x8632 (error "bug"))
1578         (:x8664 *x862-open-code-inline*))
1579      (let* ((no-overflow (backend-get-next-label)))
1580        (! %set-z-flag-if-s64-fits-in-fixnum node-dest s64-src)
1581        (! cbranch-true (aref *backend-labels* no-overflow) x86::x86-e-bits)
1582        (! setup-bignum-alloc-for-s64-overflow s64-src)
1583        (! %allocate-uvector node-dest)
1584        (! set-bigits-after-fixnum-overflow node-dest)
1585        (@ no-overflow))
1586      (let* ((arg_z ($ *x862-arg-z*))
1587             (imm0 (make-wired-lreg *x862-imm0* :mode (get-regspec-mode s64-src))))
1588        (x862-copy-register seg imm0 s64-src)
1589        (! call-subprim (subprim-name->offset '.SPmakes64))
1590        (x862-copy-register seg node-dest arg_z)))))
1591
1592(defun x862-box-u32 (seg node-dest u32-src)
1593  (with-x86-local-vinsn-macros (seg)
1594    (target-arch-case
1595     (:x8632
1596      (let* ((arg_z ($ *x862-arg-z*))
1597             (imm0 ($ *x862-imm0* :mode :u32)))
1598        (x862-copy-register seg imm0 u32-src)
1599        (! call-subprim (subprim-name->offset '.SPmakeu32))
1600        (x862-copy-register seg node-dest arg_z)))
1601     (:x8664
1602      (! box-fixnum node-dest u32-src)))))
1603
1604(defun x862-box-u64 (seg node-dest u64-src)
1605  (with-x86-local-vinsn-macros (seg)
1606    (if (target-arch-case
1607         (:x8632 (error "bug"))
1608         (:x8664 *x862-open-code-inline*))
1609      (let* ((no-overflow (backend-get-next-label)))
1610        (! %set-z-flag-if-u64-fits-in-fixnum node-dest u64-src)
1611        (! cbranch-true (aref *backend-labels* no-overflow) x86::x86-e-bits)
1612        (! setup-bignum-alloc-for-u64-overflow u64-src)
1613        (! %allocate-uvector node-dest)
1614        (! set-bigits-after-fixnum-overflow node-dest)
1615        (@ no-overflow))
1616      (let* ((arg_z ($ *x862-arg-z*))
1617             (imm0 ($ *x862-imm0* :mode :u64)))
1618        (x862-copy-register seg imm0 u64-src)
1619        (! call-subprim (subprim-name->offset '.SPmakeu64))
1620        (x862-copy-register seg node-dest arg_z)))))
1621
1622(defun x862-single->heap (seg dest src)
1623  (with-x86-local-vinsn-macros (seg)
1624    (! setup-single-float-allocation)
1625    (! %allocate-uvector dest)
1626    (! set-single-float-value dest src)))
1627
1628(defun x862-double->heap (seg dest src)
1629  (with-x86-local-vinsn-macros (seg)
1630    (! setup-double-float-allocation)
1631    (! %allocate-uvector dest)
1632    (! set-double-float-value dest src)))
1633
1634
1635(defun x862-vref1 (seg vreg xfer type-keyword src unscaled-idx index-known-fixnum) 
1636  (with-x86-local-vinsn-macros (seg vreg xfer)
1637    (when vreg
1638      (let* ((arch (backend-target-arch *target-backend*))
1639             (is-node (member type-keyword (arch::target-gvector-types arch)))
1640             (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch)))
1641
1642             (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
1643             (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
1644             (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
1645             (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
1646             (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector)))
1647             (vreg-class (and (not (eq vreg :push)) (hard-regspec-class vreg)))
1648             (vreg-mode
1649              (if (eql vreg-class hard-reg-class-gpr)
1650                (get-regspec-mode vreg)
1651                hard-reg-class-gpr-mode-invalid)))
1652        (cond
1653          (is-node
1654           (if (eq vreg :push)
1655             (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1656               (! push-misc-ref-c-node  src index-known-fixnum)
1657               (! push-misc-ref-node src unscaled-idx))
1658             (ensuring-node-target (target vreg)
1659               (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1660                 (! misc-ref-c-node target src index-known-fixnum)
1661                 (! misc-ref-node target src unscaled-idx)))))
1662          (is-32-bit
1663           (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-32-bit-constant-index arch)))
1664             (cond ((eq type-keyword :single-float-vector)
1665                    (with-fp-target () (fp-val :single-float)
1666                      (if (and (eql vreg-class hard-reg-class-fpr)
1667                               (eql vreg-mode hard-reg-class-fpr-mode-single))
1668                        (setq fp-val vreg))
1669                      (! misc-ref-c-single-float fp-val src index-known-fixnum)
1670                      (if (eql vreg-class hard-reg-class-fpr)
1671                        (<- fp-val)
1672                        (ensuring-node-target (target vreg)
1673                          (! single->node target fp-val)))))
1674                   (t
1675                    (with-additional-imm-reg ()
1676                      (with-imm-target () temp
1677                        (if is-signed
1678                          (! misc-ref-c-s32 temp src index-known-fixnum)
1679                          (! misc-ref-c-u32 temp src index-known-fixnum))
1680                        (ensuring-node-target (target vreg)
1681                          (if (eq type-keyword :simple-string)
1682                            (! u32->char target temp)
1683                            (target-arch-case
1684                             (:x8632
1685                              (if is-signed
1686                                (x862-box-s32 seg target temp)
1687                                (x862-box-u32 seg target temp)))
1688                             (:x8664
1689                              (! box-fixnum target temp)))))))))
1690             (with-imm-target () idx-reg
1691               (if index-known-fixnum
1692                 (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
1693                 (! scale-32bit-misc-index idx-reg unscaled-idx))
1694               (cond ((eq type-keyword :single-float-vector)
1695                      (with-fp-target () (fp-val :single-float)
1696                        (if (and (eql vreg-class hard-reg-class-fpr)
1697                                 (eql vreg-mode hard-reg-class-fpr-mode-single))
1698                          (setq fp-val vreg))
1699                        (! misc-ref-single-float fp-val src idx-reg)
1700                        (if (eq vreg-class hard-reg-class-fpr)
1701                          (<- fp-val)
1702                          (ensuring-node-target (target vreg)
1703                            (! single->node target fp-val)))))
1704                     (t
1705                      (with-imm-target () temp
1706                        (if is-signed
1707                          (! misc-ref-s32 temp src idx-reg)
1708                          (! misc-ref-u32 temp src idx-reg))
1709                        (ensuring-node-target (target vreg)
1710                          (if (eq type-keyword :simple-string)
1711                            (! u32->char target temp)
1712                            (target-arch-case
1713                             (:x8632 (if is-signed
1714                                       (x862-box-s32 seg target temp)
1715                                       (x862-box-u32 seg target temp)))
1716                             (:x8664 (! box-fixnum target temp)))))))))))
1717          (is-8-bit
1718           (with-imm-target () temp
1719             (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-8-bit-constant-index arch)))
1720               (if is-signed
1721                 (! misc-ref-c-s8 temp src index-known-fixnum)
1722                 (! misc-ref-c-u8 temp src index-known-fixnum))
1723               (with-additional-imm-reg ()
1724                 (with-imm-target () idx-reg
1725                   (if index-known-fixnum
1726                     (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) index-known-fixnum))
1727                     (! scale-8bit-misc-index idx-reg unscaled-idx))
1728                   (if is-signed
1729                     (! misc-ref-s8 temp src idx-reg)
1730                     (! misc-ref-u8 temp src idx-reg)))))
1731             (if (eq type-keyword :simple-string)
1732               (ensuring-node-target (target vreg)
1733                 (! u32->char target temp))
1734               (if (and (= vreg-mode hard-reg-class-gpr-mode-u8)
1735                        (eq type-keyword :unsigned-8-bit-vector))
1736                 (x862-copy-register seg vreg temp)
1737                 (ensuring-node-target (target vreg)
1738                   (! box-fixnum target temp))))))
1739          (is-16-bit
1740           (with-imm-target () temp
1741             (ensuring-node-target (target vreg)
1742               (if (and index-known-fixnum
1743                        (<= index-known-fixnum (arch::target-max-16-bit-constant-index arch)))
1744                 (if is-signed
1745                   (! misc-ref-c-s16 temp src index-known-fixnum)
1746                   (! misc-ref-c-u16 temp src index-known-fixnum))
1747                 (with-imm-target () idx-reg
1748                   (if index-known-fixnum
1749                     (x862-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1)))
1750                     (! scale-16bit-misc-index idx-reg unscaled-idx))
1751                   (if is-signed
1752                     (! misc-ref-s16 temp src idx-reg)
1753                     (! misc-ref-u16 temp src idx-reg))))
1754               (! box-fixnum target temp))))
1755          ;; Down to the dregs.
1756          (is-64-bit
1757           (case type-keyword
1758             (:double-float-vector
1759              (with-fp-target () (fp-val :double-float)
1760                (if (and (eql vreg-class hard-reg-class-fpr)
1761                         (eql vreg-mode hard-reg-class-fpr-mode-double))
1762                  (setq fp-val vreg))
1763                (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1764                  (! misc-ref-c-double-float fp-val src index-known-fixnum)
1765                  (progn
1766                    (if index-known-fixnum
1767                      (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3))))
1768                    (! misc-ref-double-float fp-val src unscaled-idx)))
1769                (if (eq vreg-class hard-reg-class-fpr)
1770                  (<- fp-val)
1771                  (ensuring-node-target (target vreg)
1772                    (x862-double->heap seg target fp-val)))))
1773             ((:signed-64-bit-vector :fixnum-vector)
1774              (ensuring-node-target (target vreg)
1775
1776                (with-imm-target () (s64-reg :s64)
1777                  (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1778                    (! misc-ref-c-s64 s64-reg src index-known-fixnum)
1779                    (progn
1780                      (if index-known-fixnum
1781                        (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3))))
1782                      (! misc-ref-s64 s64-reg src unscaled-idx)))
1783                  (if (eq type-keyword :fixnum-vector)
1784                    (! box-fixnum target s64-reg)
1785                    (x862-box-s64 seg target s64-reg)))))
1786             (t
1787                (with-imm-target () (u64-reg :u64)
1788                  (if (eql vreg-mode hard-reg-class-gpr-mode-u64)
1789                    (setq u64-reg vreg))
1790                  (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1791                    (! misc-ref-c-u64 u64-reg src index-known-fixnum)
1792                    (progn
1793                      (if index-known-fixnum
1794                        (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3))))
1795                      (! misc-ref-u64 u64-reg src unscaled-idx)))
1796                  (unless (eq u64-reg vreg)
1797                    (ensuring-node-target (target vreg)
1798                      (x862-box-u64 seg target u64-reg)))))))
1799          (t
1800           (unless is-1-bit
1801             (nx-error "~& unsupported vector type: ~s"
1802                       type-keyword))
1803           (ensuring-node-target (target vreg)
1804             (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch)))
1805               (! misc-ref-c-bit-fixnum target src index-known-fixnum)
1806               (with-imm-target () bitnum
1807                 (if index-known-fixnum
1808                   (x862-lri seg bitnum index-known-fixnum)
1809                   (! scale-1bit-misc-index bitnum unscaled-idx))
1810                 (! nref-bit-vector-fixnum target bitnum src))))))))
1811    (^)))
1812
1813;;; safe = T means assume "vector" is miscobj, do bounds check.
1814;;; safe = fixnum means check that subtag of vector = "safe" and do
1815;;;        bounds check.
1816;;; safe = nil means crash&burn.
1817;;; This mostly knows how to reference the elements of an immediate miscobj.
1818(defun x862-vref (seg vreg xfer type-keyword vector index safe)
1819  (with-x86-local-vinsn-macros (seg vreg xfer)
1820    (if (null vreg)
1821      (progn
1822        (x862-form seg nil nil vector)
1823        (x862-form seg nil xfer index))
1824      (let* ((index-known-fixnum (acode-fixnum-form-p index))
1825             (unscaled-idx nil)
1826             (src nil))
1827        (if (or safe (not index-known-fixnum))
1828          (multiple-value-setq (src unscaled-idx)
1829            (x862-two-untargeted-reg-forms seg vector *x862-arg-y* index *x862-arg-z*))
1830          (setq src (x862-one-untargeted-reg-form seg vector *x862-arg-z*)))
1831        (when safe
1832          (if (typep safe 'fixnum)
1833            (! trap-unless-typecode= src safe))
1834          (unless index-known-fixnum
1835            (! trap-unless-fixnum unscaled-idx))
1836          (! check-misc-bound unscaled-idx src))
1837        (x862-vref1 seg vreg xfer type-keyword src unscaled-idx index-known-fixnum)))))
1838
1839
1840
1841(defun x862-aset2 (seg vreg xfer  array i j new safe type-keyword  dim0 dim1)
1842  (target-arch-case
1843   (:x8632 (error "not for x8632 yet")))
1844  (with-x86-local-vinsn-macros (seg target)
1845    (let* ((i-known-fixnum (acode-fixnum-form-p i))
1846           (j-known-fixnum (acode-fixnum-form-p j))
1847           (arch (backend-target-arch *target-backend*))
1848           (is-node (member type-keyword (arch::target-gvector-types arch)))
1849           (constval (x862-constant-value-ok-for-type-keyword type-keyword new))
1850           (needs-memoization (and is-node (x862-acode-needs-memoization new)))
1851           (src)
1852           (unscaled-i)
1853           (unscaled-j)
1854           (val-reg (x862-target-reg-for-aset vreg type-keyword))
1855           (constidx
1856            (and dim0 dim1 i-known-fixnum j-known-fixnum
1857                 (>= i-known-fixnum 0)
1858                 (>= j-known-fixnum 0)
1859                 (< i-known-fixnum dim0)
1860                 (< j-known-fixnum dim1)
1861                 (+ (* i-known-fixnum dim1) j-known-fixnum))))
1862      (progn
1863        (if constidx
1864          (multiple-value-setq (src val-reg)
1865            (x862-two-targeted-reg-forms seg array ($ *x862-temp0*) new val-reg))
1866          (multiple-value-setq (src unscaled-i unscaled-j val-reg)
1867            (if needs-memoization
1868              (progn
1869                (x862-four-targeted-reg-forms seg
1870                                              array ($ *x862-temp0*)
1871                                              i ($ x8664::arg_x)
1872                                              j ($ *x862-arg-y*)
1873                                              new val-reg)
1874                (values ($ *x862-temp0*) ($ x8664::arg_x) ($ *x862-arg-y*) ($ *x862-arg-z*)))
1875              (x862-four-untargeted-reg-forms seg
1876                                              array ($ *x862-temp0*)
1877                                              i ($ x8664::arg_x)
1878                                              j ($ *x862-arg-y*)
1879                                              new val-reg))))
1880        (let* ((*available-backend-imm-temps* *available-backend-imm-temps*))
1881          (when (and (= (hard-regspec-class val-reg) hard-reg-class-gpr)
1882                     (logbitp (hard-regspec-value val-reg)
1883                              *backend-imm-temps*))
1884            (use-imm-temp (hard-regspec-value val-reg)))
1885          (when safe     
1886            (when (typep safe 'fixnum)
1887              (! trap-unless-simple-array-2
1888                 src
1889                 (dpb safe target::arrayH.flags-cell-subtag-byte
1890                      (ash 1 $arh_simple_bit))
1891                 (nx-error-for-simple-2d-array-type type-keyword)))
1892            (unless i-known-fixnum
1893              (! trap-unless-fixnum unscaled-i))
1894            (unless j-known-fixnum
1895              (! trap-unless-fixnum unscaled-j)))
1896          (with-imm-target () dim1
1897            (let* ((idx-reg ($ *x862-arg-y*)))
1898              (if constidx
1899                (if needs-memoization
1900                  (x862-lri seg *x862-arg-y* (ash constidx *x862-target-fixnum-shift*)))
1901                (progn
1902                  (if safe                 
1903                    (! check-2d-bound dim1 unscaled-i unscaled-j src)
1904                    (! 2d-dim1 dim1 src))
1905                  (! 2d-unscaled-index idx-reg dim1 unscaled-i unscaled-j)))
1906              (let* ((v ($ x8664::arg_x)))
1907                (! array-data-vector-ref v src)
1908                (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)))))))))
1909
1910
1911(defun x862-aset3 (seg vreg xfer  array i j k new safe type-keyword  dim0 dim1 dim2)
1912  (target-arch-case
1913   (:x8632 (error "not for x8632 yet")))
1914  (with-x86-local-vinsn-macros (seg target)
1915    (let* ((i-known-fixnum (acode-fixnum-form-p i))
1916           (j-known-fixnum (acode-fixnum-form-p j))
1917           (k-known-fixnum (acode-fixnum-form-p k))
1918           (arch (backend-target-arch *target-backend*))
1919           (is-node (member type-keyword (arch::target-gvector-types arch)))
1920           (constval (x862-constant-value-ok-for-type-keyword type-keyword new))
1921           (needs-memoization (and is-node (x862-acode-needs-memoization new)))
1922           (src)
1923           (unscaled-i)
1924           (unscaled-j)
1925           (unscaled-k)
1926           (val-reg (x862-target-reg-for-aset vreg type-keyword))
1927           (constidx
1928            (and dim0 dim1 dim2 i-known-fixnum j-known-fixnum k-known-fixnum
1929                 (>= i-known-fixnum 0)
1930                 (>= j-known-fixnum 0)
1931                 (>= k-known-fixnum 0)
1932                 (< i-known-fixnum dim0)
1933                 (< j-known-fixnum dim1)
1934                 (< k-known-fixnum dim2)
1935                 (+ (* i-known-fixnum dim1 dim2)
1936                    (* j-known-fixnum dim2)
1937                    k-known-fixnum))))
1938      (progn
1939        (if constidx
1940          (multiple-value-setq (src val-reg)
1941            (x862-two-targeted-reg-forms seg array ($ *x862-temp0*) new val-reg))
1942          (progn
1943            (setq src ($ x8664::temp1)
1944                  unscaled-i ($ *x862-temp0*)
1945                  unscaled-j ($ x8664::arg_x)
1946                  unscaled-k ($ *x862-arg-y*))
1947            (x862-push-register
1948             seg
1949             (x862-one-untargeted-reg-form seg array ($ *x862-arg-z*)))
1950            (x862-four-targeted-reg-forms seg
1951                                          i ($ *x862-temp0*)
1952                                          j ($ x8664::arg_x)
1953                                          k ($ *x862-arg-y*)
1954                                          new val-reg)
1955            (x862-pop-register seg src)))
1956        (let* ((*available-backend-imm-temps* *available-backend-imm-temps*))
1957          (when (and (= (hard-regspec-class val-reg) hard-reg-class-gpr)
1958                     (logbitp (hard-regspec-value val-reg)
1959                              *backend-imm-temps*))
1960            (use-imm-temp (hard-regspec-value val-reg)))
1961       
1962          (when safe     
1963            (when (typep safe 'fixnum)
1964              (! trap-unless-simple-array-3
1965                 src
1966                 (dpb safe target::arrayH.flags-cell-subtag-byte
1967                      (ash 1 $arh_simple_bit))
1968                 (nx-error-for-simple-3d-array-type type-keyword)))
1969            (unless i-known-fixnum
1970              (! trap-unless-fixnum unscaled-i))
1971            (unless j-known-fixnum
1972              (! trap-unless-fixnum unscaled-j))
1973            (unless k-known-fixnum
1974              (! trap-unless-fixnum unscaled-k)))
1975          (with-imm-target () dim1
1976            (with-imm-target (dim1) dim2
1977              (let* ((idx-reg ($ *x862-arg-y*)))
1978                (if constidx
1979                  (when needs-memoization
1980                    (x862-lri seg idx-reg (ash constidx *x862-target-fixnum-shift*)))
1981                  (progn
1982                    (if safe                 
1983                      (! check-3d-bound dim1 dim2 unscaled-i unscaled-j unscaled-k src)
1984                      (! 3d-dims dim1 dim2 src))
1985                    (! 3d-unscaled-index idx-reg dim1 dim2 unscaled-i unscaled-j unscaled-k)))
1986                (let* ((v ($ x8664::arg_x)))
1987                  (! array-data-vector-ref v src)
1988                  (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))))))))))
1989
1990
1991(defun x862-aref2 (seg vreg xfer array i j safe typekeyword &optional dim0 dim1)
1992  (target-arch-case
1993   (:x8632 (error "not for x8632 yet")))
1994  (with-x86-local-vinsn-macros (seg vreg xfer)
1995    (let* ((i-known-fixnum (acode-fixnum-form-p i))
1996           (j-known-fixnum (acode-fixnum-form-p j))
1997           (src)
1998           (unscaled-i)
1999           (unscaled-j)
2000           (constidx
2001            (and dim0 dim1 i-known-fixnum j-known-fixnum
2002                 (>= i-known-fixnum 0)
2003                 (>= j-known-fixnum 0)
2004                 (< i-known-fixnum dim0)
2005                 (< j-known-fixnum dim1)
2006                 (+ (* i-known-fixnum dim1) j-known-fixnum))))
2007      (if constidx
2008        (setq src (x862-one-targeted-reg-form seg array ($ *x862-arg-z*)))
2009        (multiple-value-setq (src unscaled-i unscaled-j)
2010          (x862-three-untargeted-reg-forms seg
2011                                           array x8664::arg_x
2012                                           i *x862-arg-y*
2013                                           j *x862-arg-z*)))
2014      (when safe       
2015        (when (typep safe 'fixnum)
2016          (! trap-unless-simple-array-2
2017             src
2018             (dpb safe target::arrayH.flags-cell-subtag-byte
2019                  (ash 1 $arh_simple_bit))
2020             (nx-error-for-simple-2d-array-type typekeyword)))
2021        (unless i-known-fixnum
2022          (! trap-unless-fixnum unscaled-i))
2023        (unless j-known-fixnum
2024          (! trap-unless-fixnum unscaled-j)))
2025      (with-node-target (src) idx-reg
2026        (with-imm-target () dim1
2027          (unless constidx
2028            (if safe                   
2029              (! check-2d-bound dim1 unscaled-i unscaled-j src)
2030              (! 2d-dim1 dim1 src))
2031            (! 2d-unscaled-index idx-reg dim1 unscaled-i unscaled-j))
2032          (with-node-target (idx-reg) v
2033            (! array-data-vector-ref v src)
2034            (x862-vref1 seg vreg xfer typekeyword v idx-reg constidx)))))))
2035
2036(defun x862-aref3 (seg vreg xfer array i j k safe typekeyword &optional dim0 dim1 dim2)
2037  (target-arch-case
2038   (:x8632 (error "not for x8632 yet")))
2039  (with-x86-local-vinsn-macros (seg vreg xfer)
2040    (let* ((i-known-fixnum (acode-fixnum-form-p i))
2041           (j-known-fixnum (acode-fixnum-form-p j))
2042           (k-known-fixnum (acode-fixnum-form-p k))
2043           (src)
2044           (unscaled-i)
2045           (unscaled-j)
2046           (unscaled-k)
2047           (constidx
2048            (and dim0 dim1 i-known-fixnum j-known-fixnum k-known-fixnum
2049                 (>= i-known-fixnum 0)
2050                 (>= j-known-fixnum 0)
2051                 (>= k-known-fixnum 0)
2052                 (< i-known-fixnum dim0)
2053                 (< j-known-fixnum dim1)
2054                 (< k-known-fixnum dim2)
2055                 (+ (* i-known-fixnum dim1 dim2)
2056                    (* j-known-fixnum dim2)
2057                    k-known-fixnum))))
2058      (if constidx
2059        (setq src (x862-one-targeted-reg-form seg array ($ *x862-arg-z*)))
2060        (multiple-value-setq (src unscaled-i unscaled-j unscaled-k)
2061          (x862-four-untargeted-reg-forms seg
2062                                           array *x862-temp0*
2063                                           i x8664::arg_x
2064                                           j *x862-arg-y*
2065                                           k *x862-arg-z*)))
2066      (when safe       
2067        (when (typep safe 'fixnum)
2068          (! trap-unless-simple-array-3
2069             src
2070             (dpb safe target::arrayH.flags-cell-subtag-byte
2071                  (ash 1 $arh_simple_bit))
2072             (nx-error-for-simple-3d-array-type typekeyword)))
2073        (unless i-known-fixnum
2074          (! trap-unless-fixnum unscaled-i))
2075        (unless j-known-fixnum
2076          (! trap-unless-fixnum unscaled-j))
2077        (unless k-known-fixnum
2078          (! trap-unless-fixnum unscaled-k)))
2079      (with-node-target (src) idx-reg
2080        (with-imm-target () dim1
2081          (with-imm-target (dim1) dim2
2082            (unless constidx
2083              (if safe                   
2084                (! check-3d-bound dim1 dim2 unscaled-i unscaled-j unscaled-k src)
2085                (! 3d-dims dim1 dim2 src))
2086              (! 3d-unscaled-index idx-reg dim1 dim2 unscaled-i unscaled-j unscaled-k))))
2087        (with-node-target (idx-reg) v
2088          (! array-data-vector-ref v src)
2089          (x862-vref1 seg vreg xfer typekeyword v idx-reg constidx))))))
2090
2091
2092
2093(defun x862-natural-vset (seg vreg xfer vector index value safe)
2094  (with-x86-local-vinsn-macros (seg vreg xfer)
2095    (let* ((index-known-fixnum (acode-fixnum-form-p index))
2096           (arch (backend-target-arch *target-backend*))
2097           (src nil)
2098           (unscaled-idx nil))
2099      (with-imm-target () (target :natural)
2100        (if (or safe (not index-known-fixnum))
2101          (multiple-value-setq (src unscaled-idx target)
2102            (x862-three-untargeted-reg-forms seg vector *x862-arg-y* index *x862-arg-z* value (or vreg target)))
2103          (multiple-value-setq (src target)
2104            (x862-two-untargeted-reg-forms seg vector *x862-arg-y* value (or vreg target))))
2105        (when safe
2106          (with-imm-temps (target) ()   ; Don't use target in type/bounds check
2107            (if (typep safe 'fixnum)
2108              (! trap-unless-typecode= src safe))
2109            (unless index-known-fixnum
2110              (! trap-unless-fixnum unscaled-idx))
2111            (! check-misc-bound unscaled-idx src)))
2112        (target-arch-case
2113         
2114         (:x8664
2115          (if (and index-known-fixnum
2116                   (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
2117            (! misc-set-c-u64 target src index-known-fixnum)
2118            (progn
2119              (if index-known-fixnum
2120                (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3))))
2121              (! misc-set-u64 target src unscaled-idx)))))
2122        (<- target)                     ; should be a no-op in this case
2123        (^)))))
2124
2125
2126(defun x862-constant-value-ok-for-type-keyword (type-keyword form)
2127  (let* ((arch (backend-target-arch *target-backend*))
2128         (is-node  (member type-keyword (arch::target-gvector-types arch))))
2129    (if is-node
2130      (cond ((eq form *nx-nil*)
2131             (arch::target-nil-value arch))
2132            ((eq form *nx-t*)
2133             (+ (arch::target-nil-value arch) (arch::target-t-offset arch)))
2134            (t
2135             (let* ((fixval (acode-fixnum-form-p form)))
2136               (if fixval
2137                 (ash fixval (arch::target-fixnum-shift arch))))))
2138      (if (and (acode-p form)
2139               (or (eq (acode-operator form) (%nx1-operator immediate))
2140                   (eq (acode-operator form) (%nx1-operator fixnum))))
2141        (let* ((val (%cadr form))
2142
2143               (typep (cond ((eq type-keyword :signed-32-bit-vector)
2144                             (typep val '(signed-byte 32)))
2145                            ((eq type-keyword :single-float-vector)
2146                             (typep val 'short-float))
2147                            ((eq type-keyword :double-float-vector)
2148                             (typep val 'double-float))
2149                            ((eq type-keyword :simple-string)
2150                             (typep val 'base-char))
2151                            ((eq type-keyword :signed-8-bit-vector)
2152                             (typep val '(signed-byte 8)))
2153                            ((eq type-keyword :unsigned-8-bit-vector)
2154                             (typep val '(unsigned-byte 8)))
2155                            ((eq type-keyword :signed-16-bit-vector) 
2156                             (typep val '(signed-byte 16)))
2157                            ((eq type-keyword :unsigned-16-bit-vector)
2158                             (typep val '(unsigned-byte 16)))
2159                            ((eq type-keyword :bit-vector)
2160                             (typep val 'bit)))))
2161          (if typep val))))))
2162
2163(defun x862-target-reg-for-aset (vreg type-keyword)
2164  (let* ((arch (backend-target-arch *target-backend*))
2165         (is-node (member type-keyword (arch::target-gvector-types arch)))
2166         (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch)))
2167         (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
2168         (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
2169         (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
2170         (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
2171         (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector)))
2172         (vreg-class (if (and vreg (not (eq vreg :push))) (hard-regspec-class vreg)))
2173         (vreg-mode (if (or (eql vreg-class hard-reg-class-gpr)
2174                            (eql vreg-class hard-reg-class-fpr))
2175                      (get-regspec-mode vreg)))
2176         (next-imm-target (available-imm-temp  *available-backend-imm-temps*))
2177         (next-fp-target (available-fp-temp *available-backend-fp-temps*))
2178         (acc (make-wired-lreg *x862-arg-z*)))
2179    (cond ((or is-node
2180               (eq vreg :push)
2181               is-1-bit
2182               (eq type-keyword :simple-string)
2183               (eq type-keyword :fixnum-vector)
2184               (and (eql vreg-class hard-reg-class-gpr)
2185                    (eql vreg-mode hard-reg-class-gpr-mode-node)))
2186           acc)
2187          ;; If there's no vreg - if we're setting for effect only, and
2188          ;; not for value - we can target an unboxed register directly.
2189          ;; Usually.
2190          ((null vreg)
2191           (cond (is-64-bit
2192                  (if (eq type-keyword :double-float-vector)
2193                    (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-double)
2194                    (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s64 hard-reg-class-gpr-mode-u64))))
2195                 (is-32-bit
2196                  (if (eq type-keyword :single-float-vector)
2197                    (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-single)
2198                    (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s32 hard-reg-class-gpr-mode-u32))))
2199                 (is-16-bit
2200                  (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s16 hard-reg-class-gpr-mode-u16)))
2201                 (is-8-bit
2202                  (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s8 hard-reg-class-gpr-mode-u8)))
2203                 (t "Bug: can't determine operand size for ~s" type-keyword)))
2204          ;; Vreg is non-null.  We might be able to use it directly.
2205          (t
2206           (let* ((lreg (if vreg-mode
2207                          (make-unwired-lreg (lreg-value vreg)))))
2208             (if 
2209               (cond
2210                 (is-64-bit
2211                  (if (eq type-keyword :double-float-vector)
2212                    (and (eql vreg-class hard-reg-class-fpr)
2213                         (eql vreg-mode hard-reg-class-fpr-mode-double))
2214                      (if is-signed
2215                        (and (eql vreg-class hard-reg-class-gpr)
2216                                 (eql vreg-mode hard-reg-class-gpr-mode-s64))
2217                        (and (eql vreg-class hard-reg-class-gpr)
2218                                 (eql vreg-mode hard-reg-class-gpr-mode-u64)))))
2219                   (is-32-bit
2220                    (if (eq type-keyword :single-float-vector)
2221                      (and (eql vreg-class hard-reg-class-fpr)
2222                               (eql vreg-mode hard-reg-class-fpr-mode-single))
2223                      (if is-signed
2224                        (and (eql vreg-class hard-reg-class-gpr)
2225                                 (or (eql vreg-mode hard-reg-class-gpr-mode-s32)
2226                                     (eql vreg-mode hard-reg-class-gpr-mode-s64)))
2227                        (and (eql vreg-class hard-reg-class-gpr)
2228                                 (or (eql vreg-mode hard-reg-class-gpr-mode-u32)
2229                                     (eql vreg-mode hard-reg-class-gpr-mode-u64)
2230                                     (eql vreg-mode hard-reg-class-gpr-mode-s64))))))
2231                   (is-16-bit
2232                    (if is-signed
2233                      (and (eql vreg-class hard-reg-class-gpr)
2234                               (or (eql vreg-mode hard-reg-class-gpr-mode-s16)
2235                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
2236                                   (eql vreg-mode hard-reg-class-gpr-mode-s64)))
2237                      (and (eql vreg-class hard-reg-class-gpr)
2238                               (or (eql vreg-mode hard-reg-class-gpr-mode-u16)
2239                                   (eql vreg-mode hard-reg-class-gpr-mode-u32)
2240                                   (eql vreg-mode hard-reg-class-gpr-mode-u64)
2241                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
2242                                   (eql vreg-mode hard-reg-class-gpr-mode-s64)))))
2243                   (t
2244                    (if is-signed
2245                      (and (eql vreg-class hard-reg-class-gpr)
2246                               (or (eql vreg-mode hard-reg-class-gpr-mode-s8)
2247                                   (eql vreg-mode hard-reg-class-gpr-mode-s16)
2248                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
2249                                   (eql vreg-mode hard-reg-class-gpr-mode-s64)))
2250                      (and (eql vreg-class hard-reg-class-gpr)
2251                               (or (eql vreg-mode hard-reg-class-gpr-mode-u8)
2252                                   (eql vreg-mode hard-reg-class-gpr-mode-u16)
2253                                   (eql vreg-mode hard-reg-class-gpr-mode-u32)
2254                                   (eql vreg-mode hard-reg-class-gpr-mode-u64)
2255                                   (eql vreg-mode hard-reg-class-gpr-mode-s16)
2256                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
2257                                   (eql vreg-mode hard-reg-class-gpr-mode-s64))))))
2258               lreg
2259               acc))))))
2260
2261(defun x862-unboxed-reg-for-aset (seg type-keyword result-reg safe constval)
2262  (with-x86-local-vinsn-macros (seg)
2263    (let* ((arch (backend-target-arch *target-backend*))
2264           (is-node (member type-keyword (arch::target-gvector-types arch)))
2265           (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
2266           (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
2267           (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
2268           (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
2269           (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector)))
2270           (result-is-node-gpr (and (eql (hard-regspec-class result-reg)
2271                                         hard-reg-class-gpr)
2272                                    (eql (get-regspec-mode result-reg)
2273                                         hard-reg-class-gpr-mode-node)))
2274           (next-imm-target (available-imm-temp *available-backend-imm-temps*))
2275           (next-fp-target (available-fp-temp *available-backend-fp-temps*)))
2276      (if (or is-node (not result-is-node-gpr))
2277        result-reg
2278        (cond (is-64-bit
2279               (if (eq type-keyword :double-float-vector)
2280                 (let* ((reg (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-double)))
2281                   (if safe
2282                     (! get-double? reg result-reg)
2283                     (! get-double reg result-reg))
2284                   reg)
2285                 (if is-signed
2286                   (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s64)))
2287                     (if (eq type-keyword :fixnum-vector)
2288                       (progn
2289                         (when safe
2290                           (! trap-unless-fixnum result-reg))
2291                         (! fixnum->signed-natural reg result-reg))
2292                       (! unbox-s64 reg result-reg))
2293                     reg)
2294                   (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u64)))
2295                     (! unbox-u64 reg result-reg)
2296                     reg))))
2297              (is-32-bit
2298               ;; Generally better to use a GPR for the :SINGLE-FLOAT-VECTOR
2299               ;; case here.
2300               (if is-signed             
2301                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s32)))
2302                   (if (eq type-keyword :fixnum-vector)
2303                     (progn
2304                       (when safe
2305                         (! trap-unless-fixnum result-reg))
2306                       (! fixnum->signed-natural reg result-reg))
2307                     (! unbox-s32 reg result-reg))
2308                   reg)
2309                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u32)))
2310                   (cond ((eq type-keyword :simple-string)
2311                          (if (characterp constval)
2312                            (x862-lri seg reg (char-code constval))
2313                            (! unbox-base-char reg result-reg)))
2314                         ((eq type-keyword :single-float-vector)
2315                          (if (typep constval 'single-float)
2316                            (x862-lri seg reg (single-float-bits constval))
2317                            (progn
2318                              (when safe
2319                                (! trap-unless-single-float result-reg))
2320                              (! single-float-bits reg result-reg))))
2321                         (t
2322                          (if (typep constval '(unsigned-byte 32))
2323                            (x862-lri seg reg constval)
2324                            (if *x862-reckless*
2325                              (target-arch-case
2326                               (:x8632 (! unbox-u32 reg result-reg))
2327                               (:x8664 (! %unbox-u32 reg result-reg)))
2328                              (! unbox-u32 reg result-reg)))))
2329                   reg)))
2330              (is-16-bit
2331               (if is-signed
2332                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s16)))
2333                   (if (typep constval '(signed-byte 16))
2334                     (x862-lri seg reg constval)
2335                     (if *x862-reckless*
2336                       (! %unbox-s16 reg result-reg)
2337                       (! unbox-s16 reg result-reg)))
2338                   reg)
2339                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u16)))
2340                   (if (typep constval '(unsigned-byte 16))
2341                     (x862-lri seg reg constval)
2342                     (if *x862-reckless*
2343                       (! %unbox-u16 reg result-reg)
2344                       (! unbox-u16 reg result-reg)))
2345                   reg)))
2346              (is-8-bit
2347               (if is-signed
2348                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s8)))
2349                   (if (typep constval '(signed-byte 8))
2350                     (x862-lri seg reg constval)
2351                     (if *x862-reckless*
2352                       (! %unbox-s8 reg result-reg)
2353                       (! unbox-s8 reg result-reg)))
2354                   reg)
2355                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u8)))
2356                   (if (typep constval '(unsigned-byte 8))
2357                     (x862-lri seg reg constval)
2358                     (if *x862-reckless*
2359                       (! %unbox-u8 reg result-reg)
2360                       (! unbox-u8 reg result-reg)))
2361                   reg)))
2362              (t
2363                 (let* ((reg result-reg))
2364                   (unless (typep constval 'bit)
2365                     (when safe
2366                       (! trap-unless-bit reg )))
2367                   reg)))))))
2368
2369
2370;;; xxx
2371(defun x862-vset1 (seg vreg xfer type-keyword src unscaled-idx index-known-fixnum val-reg unboxed-val-reg constval node-value-needs-memoization)
2372  (with-x86-local-vinsn-macros (seg vreg xfer)
2373    (let* ((arch (backend-target-arch *target-backend*))
2374           (is-node (member type-keyword (arch::target-gvector-types arch)))
2375           (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch)))
2376           (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
2377           (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
2378           (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
2379           (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
2380           (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector))))
2381      (cond ((and is-node node-value-needs-memoization)
2382             (unless (and (eql (hard-regspec-value src) (target-arch-case
2383                                                         (:x8632 x8632::temp0)
2384                                                         (:x8664 x8664::arg_x)))
2385                          (eql (hard-regspec-value unscaled-idx) *x862-arg-y*)
2386                          (eql (hard-regspec-value val-reg) *x862-arg-z*))
2387               (compiler-bug "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg)))
2388             (! call-subprim-3 val-reg (subprim-name->offset '.SPgvset) src unscaled-idx val-reg))
2389            (is-node
2390             (if (and index-known-fixnum (<= index-known-fixnum
2391                                             (target-word-size-case
2392                                              (32 (arch::target-max-32-bit-constant-index arch))
2393                                              (64 (arch::target-max-64-bit-constant-index arch)))))
2394               (if (typep constval '(signed-byte 32))
2395                 (! misc-set-immediate-c-node constval src index-known-fixnum)
2396                 (! misc-set-c-node val-reg src index-known-fixnum))
2397               (progn
2398                 (if index-known-fixnum
2399                   (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum *x862-target-node-shift*))))
2400                 (if (typep constval '(signed-byte 32))
2401                   (! misc-set-immediate-node constval src unscaled-idx)
2402                   (! misc-set-node val-reg src unscaled-idx)))))
2403            (t
2404             (with-additional-imm-reg (src unscaled-idx val-reg)
2405               (with-imm-target (unboxed-val-reg) scaled-idx
2406                 (cond
2407                   (is-64-bit
2408                    (if (and index-known-fixnum
2409                             (<= index-known-fixnum
2410                                 (arch::target-max-64-bit-constant-index arch)))
2411                      (if (eq type-keyword :double-float-vector)
2412                        (! misc-set-c-double-float unboxed-val-reg src index-known-fixnum)
2413                        (if is-signed
2414                          (! misc-set-c-s64 unboxed-val-reg src index-known-fixnum)
2415                          (! misc-set-c-u64 unboxed-val-reg src index-known-fixnum)))
2416                      (progn
2417                        (if index-known-fixnum
2418                          (x862-absolute-natural seg unscaled-idx nil (+ (arch::target-misc-dfloat-offset arch) (ash index-known-fixnum 3))))
2419                        (if (eq type-keyword :double-float-vector)
2420                          (! misc-set-double-float unboxed-val-reg src unscaled-idx)
2421                          (if is-signed
2422                            (! misc-set-s64 unboxed-val-reg src unscaled-idx)
2423                            (! misc-set-u64 unboxed-val-reg src unscaled-idx))))))
2424                   (is-32-bit
2425                    (if (and index-known-fixnum
2426                             (<= index-known-fixnum
2427                                 (arch::target-max-32-bit-constant-index arch)))
2428                      (if (eq type-keyword :single-float-vector)
2429                        (if (eq (hard-regspec-class unboxed-val-reg)
2430                                hard-reg-class-fpr)
2431                          (! misc-set-c-single-float unboxed-val-reg src index-known-fixnum)
2432                          (! misc-set-c-u32 unboxed-val-reg src index-known-fixnum))
2433                        (if is-signed
2434                          (! misc-set-c-s32 unboxed-val-reg src index-known-fixnum)
2435                          (! misc-set-c-u32 unboxed-val-reg src index-known-fixnum)))
2436                      (progn
2437                        (if index-known-fixnum
2438                          (x862-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
2439                          (! scale-32bit-misc-index scaled-idx unscaled-idx))
2440                        (if (and (eq type-keyword :single-float-vector)
2441                                 (eql (hard-regspec-class unboxed-val-reg)
2442                                      hard-reg-class-fpr))
2443                          (! misc-set-single-float unboxed-val-reg src scaled-idx)
2444                          (if is-signed
2445                            (! misc-set-s32 unboxed-val-reg src scaled-idx)
2446                            (! misc-set-u32 unboxed-val-reg src scaled-idx))))))
2447                   (is-16-bit
2448                    (if (and index-known-fixnum
2449                             (<= index-known-fixnum
2450                                 (arch::target-max-16-bit-constant-index arch)))
2451                      (if is-signed
2452                        (! misc-set-c-s16 unboxed-val-reg src index-known-fixnum)
2453                        (! misc-set-c-u16 unboxed-val-reg src index-known-fixnum))
2454                      (progn
2455                        (if index-known-fixnum
2456                          (x862-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1)))
2457                          (! scale-16bit-misc-index scaled-idx unscaled-idx))
2458                        (if is-signed
2459                          (! misc-set-s16 unboxed-val-reg src scaled-idx)
2460                          (! misc-set-u16 unboxed-val-reg src scaled-idx)))))
2461                   (is-8-bit
2462                    (if (and index-known-fixnum
2463                             (<= index-known-fixnum
2464                                 (arch::target-max-8-bit-constant-index arch)))
2465                      (if is-signed
2466                        (! misc-set-c-s8 unboxed-val-reg src index-known-fixnum)
2467                        (! misc-set-c-u8  unboxed-val-reg src index-known-fixnum))
2468                      (progn
2469                        (if index-known-fixnum
2470                          (x862-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) index-known-fixnum))
2471                          (! scale-8bit-misc-index scaled-idx unscaled-idx))
2472                        (if is-signed
2473                          (! misc-set-s8 unboxed-val-reg src scaled-idx)
2474                          (! misc-set-u8 unboxed-val-reg src scaled-idx)))))
2475                   (is-1-bit
2476                    (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch)))
2477                      (if constval
2478                        (if (zerop constval)
2479                          (! set-constant-bit-to-zero src index-known-fixnum)
2480                          (! set-constant-bit-to-one src index-known-fixnum))
2481                        (progn
2482                          (! set-constant-bit-to-variable-value src index-known-fixnum val-reg)))
2483                      (progn
2484                        (if index-known-fixnum
2485                          (x862-lri seg scaled-idx index-known-fixnum)
2486                          (! scale-1bit-misc-index scaled-idx unscaled-idx))
2487                        (if constval
2488                          (if (zerop constval)
2489                            (! nset-variable-bit-to-zero src scaled-idx)
2490                            (! nset-variable-bit-to-one src scaled-idx))
2491                          (progn
2492                            (! nset-variable-bit-to-variable-value src scaled-idx val-reg)))))))))))
2493      (when (and vreg val-reg) (<- val-reg))
2494      (^))))
2495         
2496         
2497
2498(defun x862-vset (seg vreg xfer type-keyword vector index value safe)
2499  (with-x86-local-vinsn-macros (seg)
2500    (let* ((arch (backend-target-arch *target-backend*))
2501           (is-node (member type-keyword (arch::target-gvector-types arch)))
2502           (constval (x862-constant-value-ok-for-type-keyword type-keyword value))
2503           (needs-memoization (and is-node (x862-acode-needs-memoization value)))
2504           (index-known-fixnum (acode-fixnum-form-p index)))
2505      (let* ((src (target-arch-case
2506                   (:x8632 ($ x8632::temp0))
2507                   (:x8664 ($ x8664::arg_x))))
2508             (unscaled-idx ($ *x862-arg-y*))
2509             (result-reg ($ *x862-arg-z*)))
2510        (cond (needs-memoization
2511               (x862-three-targeted-reg-forms seg
2512                                              vector src
2513                                              index unscaled-idx
2514                                              value result-reg))
2515              (t
2516               (setq result-reg (x862-target-reg-for-aset vreg type-keyword))
2517               (target-arch-case
2518                (:x8632
2519                 (with-node-temps (src) ()
2520                   (x862-three-targeted-reg-forms seg
2521                                                  vector src
2522                                                  index unscaled-idx
2523                                                  value result-reg)))
2524                (:x8664
2525                 (x862-three-targeted-reg-forms seg
2526                                                vector src
2527                                                index unscaled-idx
2528                                                value result-reg)))))
2529        (when safe
2530          (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)
2531                 (value (if (eql (hard-regspec-class result-reg)
2532                                 hard-reg-class-gpr)
2533                          (hard-regspec-value result-reg)))
2534                 (result-is-imm nil))
2535            (when (and value (logbitp value *available-backend-imm-temps*))
2536              (setq *available-backend-imm-temps* (bitclr value *available-backend-imm-temps*))
2537              (setq result-is-imm t))
2538            (if (typep safe 'fixnum)
2539              (if result-is-imm
2540                (with-additional-imm-reg (src safe)
2541                  (! trap-unless-typecode= src safe))
2542                (! trap-unless-typecode= src safe)))
2543            (unless index-known-fixnum
2544              (! trap-unless-fixnum unscaled-idx))
2545            (if result-is-imm
2546              (with-additional-imm-reg (unscaled-idx src)
2547                (! check-misc-bound unscaled-idx src))
2548              (! check-misc-bound unscaled-idx src))))
2549        (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)))))
2550
2551
2552
2553(defun x862-tail-call-alias (immref sym &optional arglist)
2554  (let ((alias (cdr (assq sym *x862-tail-call-aliases*))))
2555    (if (and alias (or (null arglist) (eq (+ (length (car arglist)) (length (cadr arglist))) (cdr alias))))
2556      (make-acode (%nx1-operator immediate) (car alias))
2557      immref)))
2558
2559;;; If BODY is essentially an APPLY involving an &rest arg, try to avoid
2560;;; consing it.
2561(defun x862-eliminate-&rest (body rest key-p auxen rest-values)
2562  (when (and rest (not key-p) (not (cadr auxen)) rest-values)
2563    (when (eq (logand (the fixnum (nx-var-bits rest))
2564                      (logior $vsetqmask (ash -1 $vbitspecial)
2565                              (ash 1 $vbitclosed) (ash 1 $vbitsetq) (ash 1 $vbitcloseddownward)))
2566              0)               ; Nothing but simple references
2567      (do* ()
2568           ((not (acode-p body)))
2569        (let* ((op (acode-operator body)))
2570          (if (or (eq op (%nx1-operator lexical-function-call))
2571                  (eq op (%nx1-operator call)))
2572            (destructuring-bind (fn-form (stack-args reg-args) &optional spread-p) (%cdr body)
2573               (unless (and (eq spread-p t)
2574                           (eq (x862-lexical-reference-p (%car reg-args)) rest))
2575                (return nil))
2576              (flet ((independent-of-all-values (form)       
2577                       (setq form (acode-unwrapped-form form))
2578                       (or (x86-constant-form-p form)
2579                           (let* ((lexref (x862-lexical-reference-p form)))
2580                             (and lexref 
2581                                  (neq lexref rest)
2582                                  (dolist (val rest-values t)
2583                                    (unless (x862-var-not-set-by-form-p lexref val)
2584                                      (return))))))))
2585                (unless (or (eq op (%nx1-operator lexical-function-call))
2586                            (independent-of-all-values fn-form))
2587                  (return nil))
2588                (if (dolist (s stack-args t)
2589                          (unless (independent-of-all-values s)
2590                            (return nil)))
2591                  (let* ((arglist (append stack-args rest-values)))
2592                    (return
2593                     (make-acode op 
2594                                 fn-form 
2595                                 (if (<= (length arglist) *x862-target-num-arg-regs*)
2596                                   (list nil (reverse arglist))
2597                                   (list (butlast arglist *x862-target-num-arg-regs*)
2598                                         (reverse (last arglist *x862-target-num-arg-regs*))))
2599                                 nil)))
2600                  (return nil))))
2601            (if (eq op (%nx1-operator local-block))
2602              (setq body (%cadr body))
2603              (if (and (eq op (%nx1-operator if))
2604                       (eq (x862-lexical-reference-p (%cadr body)) rest))
2605                (setq body (%caddr body))
2606                (return nil)))))))))
2607
2608(defun x862-call-fn (seg vreg xfer fn arglist spread-p)
2609  (with-x86-local-vinsn-macros (seg vreg xfer)
2610    (when spread-p
2611      (destructuring-bind (stack-args reg-args) arglist
2612        (when (and (null (cdr reg-args))
2613                   (nx-null (acode-unwrapped-form (car reg-args))))
2614          (setq spread-p nil)
2615          (let* ((nargs (length stack-args)))
2616            (declare (fixnum nargs))
2617            (if (<= nargs *x862-target-num-arg-regs*)
2618              (setq arglist (list nil (reverse stack-args)))
2619              (setq arglist (list (butlast stack-args *x862-target-num-arg-regs*) (reverse (last stack-args *x862-target-num-arg-regs*)))))))))
2620    (let* ((lexref (x862-lexical-reference-p fn))
2621           (simple-case (or (fixnump fn)
2622                            (typep fn 'lreg)
2623                            (x862-immediate-function-p fn)
2624                            (and 
2625                             lexref
2626                             (not spread-p)
2627                             (flet ((all-simple (args)
2628                                      (dolist (arg args t)
2629                                        (when (and arg (not (x862-var-not-set-by-form-p lexref arg)))
2630                                          (return)))))
2631                               (and (all-simple (car arglist))
2632                                    (all-simple (cadr arglist))
2633                                    (setq fn (var-ea lexref)))))))
2634           (cstack *x862-cstack*)
2635           (top *x862-top-vstack-lcell*)
2636           (vstack *x862-vstack*))
2637      (setq xfer (or xfer 0))
2638      (when (and (eq xfer $backend-return)
2639                 (eq 0 *x862-undo-count*)
2640                 (acode-p fn)
2641                 (eq (acode-operator fn) (%nx1-operator immediate))
2642                 (symbolp (cadr fn)))
2643        (setq fn (x862-tail-call-alias fn (%cadr fn) arglist)))
2644     
2645      (if (and (eq xfer $backend-return) (not (x862-tailcallok xfer)))
2646        (progn
2647          (x862-call-fn seg vreg $backend-mvpass fn arglist spread-p)
2648          (x862-set-vstack (%i+ (if simple-case 0 *x862-target-node-size*) vstack))
2649          (setq  *x862-cstack* cstack)
2650          (let ((*x862-returning-values* t)) (x862-do-return seg)))
2651        (let* ((mv-p (x862-mv-p xfer))
2652               (mv-return-label (if (and mv-p
2653                                         (not (x862-tailcallok xfer)))
2654                                  (backend-get-next-label))))
2655          (unless simple-case
2656            (x862-vpush-register seg (x862-one-untargeted-reg-form seg fn *x862-arg-z*))
2657            (setq fn (x862-vloc-ea vstack)))
2658          (x862-invoke-fn seg fn (x862-arglist seg arglist mv-return-label) spread-p xfer mv-return-label)
2659          (if (and (logbitp $backend-mvpass-bit xfer)
2660                   (not simple-case))
2661            (progn
2662              (! save-values)
2663              (! vstack-discard 1)
2664              (x862-set-nargs seg 0)
2665              (! recover-values))
2666            (unless (or mv-p simple-case)
2667              (! vstack-discard 1)))
2668          (x862-set-vstack vstack)
2669          (setq *x862-top-vstack-lcell* top)
2670          (setq *x862-cstack* cstack)
2671          (when (or (logbitp $backend-mvpass-bit xfer) (not mv-p))
2672            (<- *x862-arg-z*)
2673            (x862-branch seg (logand (lognot $backend-mvpass-mask) xfer)))))
2674      nil)))
2675
2676(defun x862-restore-full-lisp-context (seg)
2677  (with-x86-local-vinsn-macros (seg)
2678    (! restore-full-lisp-context)))
2679
2680(defun x862-emit-aligned-label (seg labelnum)
2681  (with-x86-local-vinsn-macros (seg)
2682    (! emit-aligned-label (aref *backend-labels* labelnum))
2683    (@ labelnum)
2684    (target-arch-case
2685     (:x8632
2686      (! recover-fn))
2687     (:x8664
2688      (! recover-fn-from-rip)))))
2689
2690 
2691(defun x862-call-symbol (seg jump-p)
2692  (with-x86-local-vinsn-macros (seg)
2693    (if jump-p
2694      (! jump-known-symbol)
2695      (! call-known-symbol *x862-arg-z*))))
2696
2697;;; Nargs = nil -> multiple-value case.
2698(defun x862-invoke-fn (seg fn nargs spread-p xfer &optional mvpass-label)
2699  (with-x86-local-vinsn-macros (seg)
2700    (let* ((f-op (acode-unwrapped-form fn))
2701           (immp (and (consp f-op)
2702                      (eq (%car f-op) (%nx1-operator immediate))))
2703           (symp (and immp (symbolp (%cadr f-op))))
2704           (label-p (and (fixnump fn) 
2705                         (locally (declare (fixnum fn))
2706                           (and (= fn -2) (- fn)))))
2707           (tail-p (eq xfer $backend-return))
2708           (func (if (consp f-op) (%cadr f-op)))
2709           (a-reg nil)
2710           (lfunp (and (acode-p f-op) 
2711                       (eq (acode-operator f-op) (%nx1-operator simple-function))))
2712           (expression-p (or (typep fn 'lreg) (and (fixnump fn) (not label-p))))
2713           (callable (or symp lfunp label-p))
2714           (destreg (if symp ($ *x862-fname*) (unless label-p ($ *x862-temp0*))))
2715           (alternate-tail-call
2716            (and tail-p label-p *x862-tail-label* (eql nargs *x862-tail-nargs*) (not spread-p))))
2717      (when expression-p
2718        ;;Have to do this before spread args, since might be vsp-relative.
2719        (if nargs
2720          (x862-do-lexical-reference seg destreg fn)
2721          (x862-copy-register seg destreg fn)))
2722      (if (or symp lfunp)
2723        (setq func (if symp
2724                     (x862-symbol-entry-locative func)
2725                     (x862-afunc-lfun-ref func))
2726              a-reg (x862-register-constant-p func)))
2727      (when tail-p
2728        #-no-compiler-bugs
2729        (unless (or immp symp lfunp (typep fn 'lreg) (fixnump fn)) (compiler-bug "Well, well, well.  How could this have happened ?"))
2730        (when a-reg
2731          (x862-copy-register seg destreg a-reg))
2732        (unless spread-p
2733          (unless alternate-tail-call
2734            (x862-restore-nvrs seg *x862-register-restore-ea* *x862-register-restore-count* (and nargs (<= nargs *x862-target-num-arg-regs*))))))
2735      (if spread-p
2736        (progn
2737          (x862-set-nargs seg (%i- nargs 1))
2738                                        ; .SPspread-lexpr-z & .SPspreadargz preserve temp1
2739          (target-arch-case
2740           (:x8632
2741            (! save-node-register-to-spill-area *x862-temp0*)))
2742          (if (eq spread-p 0)
2743            (! spread-lexpr)
2744            (! spread-list))
2745          (target-arch-case
2746           (:x8632
2747            (! load-node-register-from-spill-area *x862-temp0*)))
2748
2749          (when (and tail-p *x862-register-restore-count*)
2750            (x862-restore-nvrs seg *x862-register-restore-ea* *x862-register-restore-count* nil)))
2751        (if nargs
2752          (unless alternate-tail-call (x862-set-nargs seg nargs))
2753          (! pop-argument-registers)))
2754      (if callable
2755        (if (not tail-p)
2756          (if (x862-mvpass-p xfer)
2757            (let* ((call-reg (if symp ($ *x862-fname*) ($ *x862-temp0*))))
2758              (unless mvpass-label (compiler-bug "no label for mvpass"))
2759              (if label-p
2760                (x862-copy-register seg call-reg ($ *x862-fn*))
2761                (if a-reg
2762                  (x862-copy-register seg call-reg  a-reg)
2763                  (x862-store-immediate seg func call-reg)))
2764              (if symp
2765                (! pass-multiple-values-symbol)
2766                (! pass-multiple-values))
2767              (when mvpass-label
2768                (@= mvpass-label)))
2769            (progn 
2770              (if label-p
2771                (progn
2772                  (! call-label (aref *backend-labels* 2)))
2773                (progn
2774                  (if a-reg
2775                    (x862-copy-register seg destreg a-reg)
2776                    (x862-store-immediate seg func destreg))
2777                  (if symp
2778                    (x862-call-symbol seg nil)
2779                    (! call-known-function))))))
2780          (if alternate-tail-call
2781            (progn
2782              (x862-unwind-stack seg xfer 0 0 *x862-tail-vsp*)
2783              (! jump (aref *backend-labels* *x862-tail-label*)))
2784            (progn
2785              (x862-unwind-stack seg xfer 0 0 #x7fffff)
2786              (if (and (not spread-p) nargs (%i<= nargs *x862-target-num-arg-regs*))
2787                (progn
2788                  (unless (or label-p a-reg) (x862-store-immediate seg func destreg))
2789                  (x862-restore-full-lisp-context seg)
2790                  (if label-p
2791                    (! jump (aref *backend-labels* 1))
2792                    (progn
2793                      (if symp
2794                        (x862-call-symbol seg t)
2795                        (! jump-known-function)))))
2796                (progn
2797                  (unless (or label-p a-reg) (x862-store-immediate seg func destreg))
2798                  (when label-p
2799                    (x862-copy-register seg *x862-temp0* *x862-fn*))
2800
2801                  (cond ((or spread-p (null nargs))
2802                         (if symp
2803                           (! tail-call-sym-gen)
2804                           (! tail-call-fn-gen)))
2805                        ((%i> nargs *x862-target-num-arg-regs*)
2806                         (if symp
2807                           (! tail-call-sym-slide)
2808                           (! tail-call-fn-slide)))
2809                        (t
2810                         (if symp
2811                           (! tail-call-sym-vsp)
2812                           (! tail-call-fn-vsp)))))))))
2813        ;; The general (funcall) case: we don't know (at compile-time)
2814        ;; for sure whether we've got a symbol or a (local, constant)
2815        ;; function.
2816        (progn
2817          (unless (or (fixnump fn) (typep fn 'lreg))
2818            (x862-one-targeted-reg-form seg fn destreg))
2819          (if (not tail-p)
2820            (if (x862-mvpass-p xfer)
2821              (progn (! pass-multiple-values)
2822                     (when mvpass-label
2823                       (@= mvpass-label)))
2824              (! funcall))                 
2825            (cond ((or (null nargs) spread-p)
2826                   (! tail-funcall-gen))
2827                  ((%i> nargs *x862-target-num-arg-regs*)
2828                   (! tail-funcall-slide))
2829                  (t
2830                   (! restore-full-lisp-context)
2831                   (! tail-funcall)))))))
2832    nil))
2833
2834(defun x862-seq-fbind (seg vreg xfer vars afuncs body p2decls)
2835  (let* ((old-stack (x862-encode-stack))
2836         (copy afuncs)
2837         (func nil))
2838    (with-x86-p2-declarations p2decls 
2839      (dolist (var vars) 
2840        (when (neq 0 (afunc-fn-refcount (setq func (pop afuncs))))
2841          (x862-seq-bind-var seg var (nx1-afunc-ref func))))
2842      (x862-undo-body seg vreg xfer body old-stack)
2843      (dolist (var vars)
2844        (when (neq 0 (afunc-fn-refcount (setq func (pop copy))))
2845          (x862-close-var seg var))))))
2846
2847(defun x862-make-closure (seg afunc downward-p)
2848  (with-x86-local-vinsn-macros (seg)
2849    (flet ((var-to-reg (var target)
2850             (let* ((ea (var-ea (var-bits var))))
2851               (if ea
2852                 (x862-addrspec-to-reg seg (x862-ea-open ea) target)
2853                 (! load-nil target))
2854               target))
2855           (set-some-cells (dest cellno c0 c1 c2 c3)
2856             (declare (fixnum cellno))
2857             (! misc-set-c-node c0 dest cellno)
2858             (incf cellno)
2859             (when c1
2860               (! misc-set-c-node c1 dest cellno)
2861               (incf cellno)
2862               (when c2
2863                 (! misc-set-c-node c2 dest cellno)
2864                 (incf cellno)
2865                 (when c3
2866                   (! misc-set-c-node c3 dest cellno)
2867                   (incf cellno))))
2868             cellno))
2869      (let* ((inherited-vars (afunc-inherited-vars afunc))
2870             (arch (backend-target-arch *target-backend*))
2871             (dest ($ *x862-arg-z*))
2872             (vsize (+ (length inherited-vars)
2873                       (target-arch-case
2874                        (:x8632 7)
2875                        (:x8664 5))     ; %closure-code%, afunc
2876                       1)))             ; lfun-bits
2877        (declare (list inherited-vars))
2878        (let* ((cell (target-arch-case (:x8632 6)
2879                                       (:x8664 4))))
2880          (declare (fixnum cell))
2881          (if downward-p
2882            (progn
2883              (! make-fixed-stack-gvector
2884                 dest
2885                 (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch))
2886                 (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function)))
2887              (x862-open-undo $undostkblk))
2888            (progn
2889              (x862-lri seg
2890                        *x862-imm0*
2891                        (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function)))
2892              (target-arch-case
2893               (:x8632
2894                (! setup-uvector-allocation *x862-imm0*)
2895                (x862-lri seg *x862-imm0* (- (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch)) x8632::fulltag-misc)))
2896               (:x8664
2897                (x862-lri seg x8664::imm1 (- (ash (logandc2 (+ vsize 2) 1) (arch::target-word-shift arch)) x8664::fulltag-misc))))
2898              (! %allocate-uvector dest)))
2899          (! init-nclosure *x862-arg-z*)
2900          ;;; xxx --- x8632 likely to have register conflicts with *x862-ra0*
2901          (x862-store-immediate seg (x862-afunc-lfun-ref afunc) *x862-ra0*)
2902          (target-arch-case
2903           (:x8632
2904            (with-node-temps (*x862-arg-z*) (t0)
2905              (do* ((func *x862-ra0* nil))
2906                   ((null inherited-vars))
2907                (let* ((t0r (or func (if inherited-vars
2908                                       (var-to-reg (pop inherited-vars) t0)))))
2909                  (! misc-set-c-node t0r dest cell)
2910                  (incf cell)))))
2911           (:x8664
2912            (with-node-temps (*x862-arg-z*) (t0 t1 t2 t3)
2913              (do* ((func *x862-ra0* nil))
2914                   ((null inherited-vars))
2915                (let* ((t0r (or func (if inherited-vars (var-to-reg (pop inherited-vars) t0))))
2916                       (t1r (if inherited-vars (var-to-reg (pop inherited-vars) t1)))
2917                       (t2r (if inherited-vars (var-to-reg (pop inherited-vars) t2)))
2918                       (t3r (if inherited-vars (var-to-reg (pop inherited-vars) t3))))
2919                  (setq cell (set-some-cells dest cell t0r t1r t2r t3r)))))))
2920          (x862-lri seg *x862-arg-y* (ash (logior (ash -1 $lfbits-noname-bit) (ash 1 $lfbits-trampoline-bit)) *x862-target-fixnum-shift*))
2921          (! misc-set-c-node *x862-arg-y* dest cell))
2922        (! finalize-closure dest)
2923        dest))))
2924       
2925(defun x862-symbol-entry-locative (sym)
2926  (setq sym (require-type sym 'symbol))
2927  (when (eq sym '%call-next-method-with-args)
2928    (setf (afunc-bits *x862-cur-afunc*)
2929          (%ilogior (%ilsl $fbitnextmethargsp 1) (afunc-bits *x862-cur-afunc*))))
2930  (or (assq sym *x862-fcells*)
2931      (let ((new (list sym)))
2932        (push new *x862-fcells*)
2933        new)))
2934
2935(defun x862-symbol-value-cell (sym)
2936  (setq sym (require-type sym 'symbol))
2937  (or (assq sym *x862-vcells*)
2938      (let ((new (list sym)))
2939        (push new *x862-vcells*)
2940        (ensure-binding-index sym)
2941        new)))
2942
2943
2944(defun x862-symbol-locative-p (imm)
2945  (and (consp imm)
2946       (or (memq imm *x862-vcells*)
2947           (memq imm *x862-fcells*))))
2948
2949
2950
2951
2952(defun x862-immediate-function-p (f)
2953  (setq f (acode-unwrapped-form f))
2954  (and (acode-p f)
2955       (or (eq (%car f) (%nx1-operator immediate))
2956           (eq (%car f) (%nx1-operator simple-function)))))
2957
2958(defun x86-constant-form-p (form)
2959  (setq form (nx-untyped-form form))
2960  (if form
2961    (or (nx-null form)
2962        (nx-t form)
2963        (and (consp form)
2964             (or (eq (acode-operator form) (%nx1-operator immediate))
2965                 (eq (acode-operator form) (%nx1-operator fixnum))
2966                 (eq (acode-operator form) (%nx1-operator simple-function)))))))
2967
2968
2969 
2970(defun x862-long-constant-p (form)
2971  (setq form (acode-unwrapped-form form))
2972  (or (acode-fixnum-form-p form)
2973      (and (acode-p form)
2974           (eq (acode-operator form) (%nx1-operator immediate))
2975           (setq form (%cadr form))
2976           (if (integerp form) 
2977             form))))
2978
2979
2980(defun x86-side-effect-free-form-p (form)
2981  (when (consp (setq form (acode-unwrapped-form form)))
2982    (or (x86-constant-form-p form)
2983        ;(eq (acode-operator form) (%nx1-operator bound-special-ref))
2984        (if (eq (acode-operator form) (%nx1-operator lexical-reference))
2985          (not (%ilogbitp $vbitsetq (nx-var-bits (%cadr form))))))))
2986
2987(defun x862-formlist (seg stkargs &optional revregargs)
2988  (with-x86-local-vinsn-macros (seg) 
2989    (let* ((nregs (length revregargs))
2990           (n nregs))
2991      (declare (fixnum n))
2992      (dolist (arg stkargs)
2993        (let* ((pushform (x862-acode-operator-supports-push arg)))
2994          (if pushform
2995            (progn
2996              (x862-form seg :push nil pushform)
2997              (x862-new-vstack-lcell :outgoing-argument *x862-target-lcell-size* 0 nil)
2998              (x862-adjust-vstack *x862-target-node-size*))
2999             
3000            (let* ((reg (x862-one-untargeted-reg-form seg arg *x862-arg-z*)))
3001              (x862-vpush-register-arg seg reg)))
3002          (incf n)))
3003      (when revregargs
3004        (let* ((zform (%car revregargs))
3005               (yform (%cadr revregargs))
3006               (xform (%caddr revregargs)))
3007          (if (eq 3 nregs)
3008            (progn
3009              (target-arch-case (:x8632 (compiler-bug "3 reg args on x8632?")))
3010              (x862-three-targeted-reg-forms seg xform ($ x8664::arg_x)
3011                                             yform ($ *x862-arg-y*)
3012                                             zform ($ *x862-arg-z*)))
3013            (if (eq 2 nregs)
3014              (x862-two-targeted-reg-forms seg yform ($ *x862-arg-y*) zform ($ *x862-arg-z*))
3015              (x862-one-targeted-reg-form seg zform ($ *x862-arg-z*))))))
3016      n)))
3017
3018(defun x862-arglist (seg args &optional mv-label)
3019  (with-x86-local-vinsn-macros (seg)
3020    (when mv-label
3021      (x862-vpush-label seg (aref *backend-labels* mv-label)))
3022    (when (car args)
3023      (! reserve-outgoing-frame)
3024      (x862-new-vstack-lcell :reserved *x862-target-lcell-size* 0 nil)
3025      (x862-new-vstack-lcell :reserved *x862-target-lcell-size* 0 nil)
3026      (setq *x862-vstack* (+  *x862-vstack* (* 2 *x862-target-node-size*))))
3027    (x862-formlist seg (car args) (cadr args))))
3028
3029
3030
3031
3032;;; treat form as a 32-bit immediate value and load it into immreg.
3033;;; This is the "lenient" version of 32-bit-ness; OSTYPEs and chars
3034;;; count, and we don't care about the integer's sign.
3035
3036(defun x862-unboxed-integer-arg-to-reg (seg form immreg &optional ffi-arg-type)
3037  (let* ((mode (ecase ffi-arg-type
3038                 ((nil) :natural)
3039                 (:signed-byte :s8)
3040                 (:unsigned-byte :u8)
3041                 (:signed-halfword :s16)
3042                 (:unsigned-halfword :u16)
3043                 (:signed-fullword :s32)
3044                 (:unsigned-fullword :u32)
3045                 (:unsigned-doubleword :u64)
3046                 (:signed-doubleword :s64)))
3047         (modeval (gpr-mode-name-value mode)))
3048    (with-x86-local-vinsn-macros (seg)
3049      (let* ((value (x862-long-constant-p form)))
3050        (if value
3051          (progn
3052            (unless (typep immreg 'lreg)
3053              (setq immreg (make-unwired-lreg immreg :mode modeval)))
3054            (x862-lri seg immreg value)
3055            immreg)
3056          (progn 
3057            (x862-one-targeted-reg-form seg form (make-wired-lreg *x862-imm0* :mode modeval))))))))
3058
3059
3060(defun x862-macptr-arg-to-reg (seg form address-reg) 
3061  (x862-one-targeted-reg-form seg
3062                              form 
3063                              address-reg))
3064
3065
3066(defun x862-one-lreg-form (seg form lreg)
3067  (let ((is-float (= (hard-regspec-class lreg) hard-reg-class-fpr)))
3068    (if is-float
3069      (x862-form-float seg lreg nil form)
3070      (x862-form seg lreg nil form))
3071    lreg))
3072
3073(defun x862-one-targeted-reg-form (seg form reg)
3074  (x862-one-lreg-form seg form reg))
3075
3076(defun x862-one-untargeted-lreg-form (seg form reg)
3077  (x862-one-lreg-form seg form (if (typep reg 'lreg) reg (make-unwired-lreg reg))))
3078
3079(defun x862-one-untargeted-reg-form (seg form suggested)
3080  (with-x86-local-vinsn-macros (seg)
3081    (let* ((gpr-p (= (hard-regspec-class suggested) hard-reg-class-gpr))
3082           (node-p (if gpr-p (= (get-regspec-mode suggested) hard-reg-class-gpr-mode-node))))
3083      (if node-p
3084        (let* ((ref (x862-lexical-reference-ea form))
3085               (reg (backend-ea-physical-reg ref hard-reg-class-gpr)))
3086          (if reg
3087            ref
3088            (if (nx-null form)
3089              (progn
3090                (! load-nil suggested)
3091                suggested)
3092              (if (and (acode-p form) 
3093                       (eq (acode-operator form) (%nx1-operator immediate)) 
3094                       (setq reg (x862-register-constant-p (cadr form))))
3095                reg
3096                (x862-one-untargeted-lreg-form seg form suggested)))))
3097        (x862-one-untargeted-lreg-form seg form suggested)))))
3098             
3099
3100(defun x862-push-register (seg areg)
3101  (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr))
3102         (a-single (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-single)))
3103         (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node)))
3104         vinsn)
3105    (with-x86-local-vinsn-macros (seg)
3106      (if a-node
3107        (setq vinsn (x862-vpush-register seg areg :node-temp))
3108        (if a-single
3109          (target-arch-case
3110           (:x8632
3111            (setq vinsn (! temp-push-single-float areg))
3112            (incf *x862-cstack* *x862-target-dnode-size*))
3113           (:x8664
3114            (setq vinsn (! vpush-single-float areg))
3115            (x862-new-vstack-lcell :single-float *x862-target-lcell-size* 0 nil)
3116            (x862-adjust-vstack *x862-target-node-size*)))
3117          (target-arch-case
3118           (:x8632
3119            (if a-float
3120              (progn
3121                (setq vinsn (! temp-push-double-float areg))
3122                (incf *x862-cstack* 16))
3123              (progn
3124                (setq vinsn (! temp-push-unboxed-word areg))
3125                (incf *x862-cstack* *x862-target-dnode-size*))))
3126           (:x8664
3127            (setq vinsn
3128                  (if a-float
3129                    (! temp-push-double-float areg)
3130                    (! temp-push-unboxed-word areg)))
3131            (setq *x862-cstack* (+ *x862-cstack* 16))))))
3132      vinsn)))
3133
3134(defun x862-pop-register (seg areg)
3135  (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr))
3136         (a-single (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-single)))
3137         (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node)))
3138         vinsn)
3139    (with-x86-local-vinsn-macros (seg)
3140      (if a-node
3141        (setq vinsn (x862-vpop-register seg areg))
3142        (if a-single
3143          (target-arch-case
3144           (:x8632
3145            (setq vinsn (! temp-pop-single-float areg))
3146            (decf *x862-cstack* *x862-target-dnode-size*))
3147           (:x8664
3148            (setq vinsn (! vpop-single-float areg))
3149            (setq *x862-top-vstack-lcell* (lcell-parent *x862-top-vstack-lcell*))
3150            (x862-adjust-vstack (- *x862-target-node-size*))))
3151          (target-arch-case
3152           (:x8632
3153            (if a-float
3154              (progn
3155                (setq vinsn (! temp-pop-double-float areg))
3156                (decf *x862-cstack* 16))
3157              (progn
3158                (setq vinsn (! temp-pop-unboxed-word areg))
3159                (decf *x862-cstack* *x862-target-dnode-size*))))
3160           (:x8664
3161            (setq vinsn
3162                  (if a-float
3163                    (! temp-pop-double-float areg)
3164                    (! temp-pop-unboxed-word areg)))
3165            (setq *x862-cstack* (- *x862-cstack* 16))))))
3166      vinsn)))
3167
3168(defun x862-acc-reg-for (reg)
3169  (with-x86-local-vinsn-macros (seg)
3170    (let* ((class (hard-regspec-class reg))
3171           (mode (get-regspec-mode reg)))
3172      (declare (fixnum class mode))
3173      (cond ((= class hard-reg-class-fpr)
3174             (make-wired-lreg *x862-fp1* :class class :mode mode))
3175            ((= class hard-reg-class-gpr)
3176             (if (= mode hard-reg-class-gpr-mode-node)
3177               ($ *x862-arg-z*)
3178               (make-wired-lreg *x862-imm0* :mode mode)))
3179            (t (compiler-bug "Unknown register class for reg ~s" reg))))))
3180
3181;;; The compiler often generates superfluous pushes & pops.  Try to
3182;;; eliminate them.
3183(defun x862-elide-pushes (seg push-vinsn pop-vinsn)
3184  (with-x86-local-vinsn-macros (seg)
3185    (let* ((pushed-reg (svref (vinsn-variable-parts push-vinsn) 0))
3186           (popped-reg (svref (vinsn-variable-parts pop-vinsn) 0))
3187           (same-reg (eq (hard-regspec-value pushed-reg)
3188                         (hard-regspec-value popped-reg)))
3189           (csp-p (vinsn-attribute-p push-vinsn :csp)))
3190      (when csp-p                       ; vsp case is harder.
3191        (let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p
3192                                   push-vinsn pop-vinsn pushed-reg))
3193               (popped-reg-is-set (if same-reg
3194                                    pushed-reg-is-set
3195                                    (vinsn-sequence-sets-reg-p
3196                                     push-vinsn pop-vinsn popped-reg))))
3197          (unless (and pushed-reg-is-set popped-reg-is-set)
3198            (unless same-reg
3199              (let* ((copy (if (eq (hard-regspec-class pushed-reg)
3200                                   hard-reg-class-fpr)
3201                             (if (= (get-regspec-mode pushed-reg)
3202                                    hard-reg-class-fpr-mode-double)
3203                               (! copy-double-float popped-reg pushed-reg)
3204                               (! copy-single-float popped-reg pushed-reg))
3205                             (! copy-gpr popped-reg pushed-reg))))
3206                (remove-dll-node copy)
3207                (if pushed-reg-is-set
3208                  (insert-dll-node-after copy push-vinsn)
3209                  (insert-dll-node-before copy push-vinsn))))
3210            (elide-vinsn push-vinsn)
3211            (elide-vinsn pop-vinsn)))))))
3212               
3213       
3214;;; we never leave the first form pushed (the 68K compiler had some subprims that
3215;;; would vpop the first argument out of line.)
3216(defun x862-two-targeted-reg-forms (seg aform areg bform breg)
3217  (unless (typep areg 'lreg)
3218    (warn "~s is not an lreg (1/2)" areg))
3219  (unless (typep breg 'lreg)
3220    (warn "~s is not an lreg (2/2)" breg))
3221  (let* ((avar (x862-lexical-reference-p aform))
3222         (atriv (x862-trivial-p bform))
3223         (aconst (and (not atriv) (or (x86-side-effect-free-form-p aform)
3224                                      (if avar (x862-var-not-set-by-form-p avar bform)))))
3225         apushed)
3226    (progn
3227      (unless aconst
3228        (if atriv
3229          (x862-one-targeted-reg-form seg aform areg)
3230          (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg))))))
3231      (x862-one-targeted-reg-form seg bform breg)
3232      (if aconst
3233        (x862-one-targeted-reg-form seg aform areg)
3234        (if apushed
3235          (x862-elide-pushes seg apushed (x862-pop-register seg areg)))))
3236    (values areg breg)))
3237
3238
3239(defun x862-two-untargeted-reg-forms (seg aform areg bform breg)
3240  (with-x86-local-vinsn-macros (seg)
3241    (let* ((avar (x862-lexical-reference-p aform))
3242           (adest areg)
3243           (bdest breg)
3244           (atriv (x862-trivial-p bform))
3245           (aconst (and (not atriv) (or (x86-side-effect-free-form-p aform)
3246                                        (if avar (x862-var-not-set-by-form-p avar bform)))))
3247           (apushed (not (or atriv aconst))))
3248      (progn
3249        (unless aconst
3250          (if atriv
3251            (setq adest (x862-one-untargeted-reg-form seg aform areg))
3252            (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg))))))
3253        (setq bdest (x862-one-untargeted-reg-form seg bform breg))
3254        (if aconst
3255          (setq adest (x862-one-untargeted-reg-form seg aform areg))
3256          (if apushed
3257            (x862-elide-pushes seg apushed (x862-pop-register seg areg)))))
3258      (values adest bdest))))
3259
3260
3261(defun x862-three-targeted-reg-forms (seg aform areg bform breg cform creg)
3262  (unless (typep areg 'lreg)
3263    (warn "~s is not an lreg (1/3)" areg))
3264  (unless (typep breg 'lreg)
3265    (warn "~s is not an lreg (2/3)" breg))
3266  (unless (typep creg 'lreg)
3267    (warn "~s is not an lreg (3/3)" creg))
3268  (let* ((atriv (or (null aform) 
3269                    (and (x862-trivial-p bform)
3270                         (x862-trivial-p cform))))
3271         (btriv (or (null bform)
3272                    (x862-trivial-p cform)))
3273         (aconst (and (not atriv) 
3274                      (or (x86-side-effect-free-form-p aform)
3275                          (let ((avar (x862-lexical-reference-p aform)))
3276                            (and avar 
3277                                 (x862-var-not-set-by-form-p avar bform)
3278                                 (x862-var-not-set-by-form-p avar cform))))))
3279         (bconst (and (not btriv)
3280                      (or
3281                       (x86-side-effect-free-form-p bform)
3282                       (let ((bvar (x862-lexical-reference-p bform)))
3283                         (and bvar (x862-var-not-set-by-form-p bvar cform))))))
3284         (apushed nil)
3285         (bpushed nil))
3286    (if (and aform (not aconst))
3287      (if atriv
3288        (x862-one-targeted-reg-form seg aform areg)
3289        (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg))))))
3290    (if (and bform (not bconst))
3291      (if btriv
3292        (x862-one-targeted-reg-form seg bform breg)
3293        (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg))))))
3294    (x862-one-targeted-reg-form seg cform creg)
3295    (unless btriv 
3296      (if bconst
3297        (x862-one-targeted-reg-form seg bform breg)
3298        (x862-elide-pushes seg bpushed (x862-pop-register seg breg))))
3299    (unless atriv
3300      (if aconst
3301        (x862-one-targeted-reg-form seg aform areg)
3302        (x862-elide-pushes seg apushed (x862-pop-register seg areg))))
3303    (values areg breg creg)))
3304
3305(defun x862-four-targeted-reg-forms (seg aform areg bform breg cform creg dform dreg)
3306  (unless (typep areg 'lreg)
3307    (warn "~s is not an lreg (1/4)" areg))
3308  (unless (typep breg 'lreg)
3309    (warn "~s is not an lreg (2/4)" breg))
3310  (unless (typep creg 'lreg)
3311    (warn "~s is not an lreg (3/4)" creg))
3312  (unless (typep dreg 'lreg)
3313    (warn "~s is not an lreg (4/4)" dreg))
3314  (let* ((atriv (or (null aform) 
3315                    (and (x862-trivial-p bform)
3316                         (x862-trivial-p cform)
3317                         (x862-trivial-p dform))))
3318         (btriv (or (null bform)
3319                    (and (x862-trivial-p cform)
3320                         (x862-trivial-p dform))))
3321         (ctriv (or (null cform)
3322                    (x862-trivial-p dform)))
3323         (aconst (and (not atriv) 
3324                      (or (x86-side-effect-free-form-p aform)
3325                          (let ((avar (x862-lexical-reference-p aform)))
3326                            (and avar 
3327                                 (x862-var-not-set-by-form-p avar bform)
3328                                 (x862-var-not-set-by-form-p avar cform)
3329                                 (x862-var-not-set-by-form-p avar dform))))))
3330         (bconst (and (not btriv)
3331                      (or
3332                       (x86-side-effect-free-form-p bform)
3333                       (let ((bvar (x862-lexical-reference-p bform)))
3334                         (and bvar
3335                              (x862-var-not-set-by-form-p bvar cform)
3336                              (x862-var-not-set-by-form-p bvar dform))))))
3337         (cconst (and (not ctriv)
3338                      (or
3339                       (x86-side-effect-free-form-p cform)
3340                       (let ((cvar (x862-lexical-reference-p cform)))
3341                         (and cvar (x862-var-not-set-by-form-p cvar dform))))))
3342         (apushed nil)
3343         (bpushed nil)
3344         (cpushed nil))
3345    (if (and aform (not aconst))
3346      (if atriv
3347        (x862-one-targeted-reg-form seg aform areg)
3348        (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg))))))
3349    (if (and bform (not bconst))
3350      (if btriv
3351        (x862-one-targeted-reg-form seg bform breg)
3352        (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg))))))
3353    (if (and cform (not cconst))
3354      (if ctriv
3355        (x862-one-targeted-reg-form seg cform creg)
3356        (setq cpushed (x862-push-register seg (x862-one-untargeted-reg-form seg cform (x862-acc-reg-for creg))))))
3357    (x862-one-targeted-reg-form seg dform dreg)
3358    (unless ctriv
3359      (if cconst
3360        (x862-one-targeted-reg-form seg cform creg)
3361        (x862-elide-pushes seg cpushed (x862-pop-register seg creg))))
3362    (unless btriv 
3363      (if bconst
3364        (x862-one-targeted-reg-form seg bform breg)
3365        (x862-elide-pushes seg bpushed (x862-pop-register seg breg))))
3366    (unless atriv
3367      (if aconst
3368        (x862-one-targeted-reg-form seg aform areg)
3369        (x862-elide-pushes seg apushed (x862-pop-register seg areg))))
3370    (values areg breg creg)))
3371
3372(defun x862-three-untargeted-reg-forms (seg aform areg bform breg cform creg)
3373  (with-x86-local-vinsn-macros (seg)
3374    (let* ((atriv (or (null aform) 
3375                      (and (x862-trivial-p bform)
3376                           (x862-trivial-p cform))))
3377           (btriv (or (null bform)
3378                      (x862-trivial-p cform)))
3379           (aconst (and (not atriv) 
3380                        (or (x86-side-effect-free-form-p aform)
3381                            (let ((avar (x862-lexical-reference-p aform)))
3382                              (and avar 
3383                                   (x862-var-not-set-by-form-p avar bform)
3384                                   (x862-var-not-set-by-form-p avar cform))))))
3385           (bconst (and (not btriv)
3386                        (or
3387                         (x86-side-effect-free-form-p bform)
3388                         (let ((bvar (x862-lexical-reference-p bform)))
3389                           (and bvar (x862-var-not-set-by-form-p bvar cform))))))
3390           (adest areg)
3391           (bdest breg)
3392           (cdest creg)
3393           (apushed nil)
3394           (bpushed nil))
3395      (if (and aform (not aconst))
3396        (if atriv
3397          (setq adest (x862-one-untargeted-reg-form seg aform ($ areg)))
3398          (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg))))))
3399      (if (and bform (not bconst))
3400        (if btriv
3401          (setq bdest (x862-one-untargeted-reg-form seg bform ($ breg)))
3402          (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg))))))
3403      (setq cdest (x862-one-untargeted-reg-form seg cform creg))
3404      (unless btriv 
3405        (if bconst
3406          (setq bdest (x862-one-untargeted-reg-form seg bform breg))
3407          (x862-elide-pushes seg bpushed (x862-pop-register seg breg))))
3408      (unless atriv
3409        (if aconst
3410          (setq adest (x862-one-untargeted-reg-form seg aform areg))
3411          (x862-elide-pushes seg apushed (x862-pop-register seg areg))))
3412      (values adest bdest cdest))))
3413
3414(defun x862-four-untargeted-reg-forms (seg aform areg bform breg cform creg dform dreg)
3415  (let* ((atriv (or (null aform) 
3416                    (and (x862-trivial-p bform)
3417                         (x862-trivial-p cform)
3418                         (x862-trivial-p dform))))
3419         (btriv (or (null bform)
3420                    (and (x862-trivial-p cform)
3421                         (x862-trivial-p dform))))
3422         (ctriv (or (null cform)
3423                    (x862-trivial-p dform)))
3424         (aconst (and (not atriv) 
3425                      (or (x86-side-effect-free-form-p aform)
3426                          (let ((avar (x862-lexical-reference-p aform)))
3427                            (and avar 
3428                                 (x862-var-not-set-by-form-p avar bform)
3429                                 (x862-var-not-set-by-form-p avar cform)
3430                                 (x862-var-not-set-by-form-p avar dform))))))
3431         (bconst (and (not btriv)
3432                      (or
3433                       (x86-side-effect-free-form-p bform)
3434                       (let ((bvar (x862-lexical-reference-p bform)))
3435                         (and bvar
3436                              (x862-var-not-set-by-form-p bvar cform)
3437                              (x862-var-not-set-by-form-p bvar dform))))))
3438         (cconst (and (not ctriv)
3439                      (or
3440                       (x86-side-effect-free-form-p cform)
3441                       (let ((cvar (x862-lexical-reference-p cform)))
3442                         (and cvar
3443                              (x862-var-not-set-by-form-p cvar dform))))))
3444         (adest areg)
3445         (bdest breg)
3446         (cdest creg)
3447         (ddest dreg)
3448         (apushed nil)
3449         (bpushed nil)
3450         (cpushed nil))
3451    (if (and aform (not aconst))
3452      (if atriv
3453        (setq adest (x862-one-targeted-reg-form seg aform areg))
3454        (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg))))))
3455    (if (and bform (not bconst))
3456      (if btriv
3457        (setq bdest (x862-one-untargeted-reg-form seg bform breg))
3458        (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg))))))
3459    (if (and cform (not cconst))
3460      (if ctriv
3461        (setq cdest (x862-one-untargeted-reg-form seg cform creg))
3462        (setq cpushed (x862-push-register seg (x862-one-untargeted-reg-form seg cform (x862-acc-reg-for creg))))))
3463    (setq ddest (x862-one-untargeted-reg-form seg dform dreg))
3464    (unless ctriv 
3465      (if cconst
3466        (setq cdest (x862-one-untargeted-reg-form seg cform creg))
3467        (x862-elide-pushes seg cpushed (x862-pop-register seg creg))))
3468    (unless btriv 
3469      (if bconst
3470        (setq bdest (x862-one-untargeted-reg-form seg bform breg))
3471        (x862-elide-pushes seg bpushed (x862-pop-register seg breg))))
3472    (unless atriv
3473      (if aconst
3474        (setq adest (x862-one-untargeted-reg-form seg aform areg))
3475        (x862-elide-pushes seg apushed (x862-pop-register seg areg))))
3476    (values adest bdest cdest ddest)))
3477
3478(defun x862-lri (seg reg value)
3479  (with-x86-local-vinsn-macros (seg)
3480    (! lri reg value)))
3481
3482;;; unsigned variant
3483(defun x862-lriu (seg reg value)
3484  (with-x86-local-vinsn-macros (seg)
3485    (! lriu reg value)))
3486
3487(defun x862-multiple-value-body (seg form)
3488  (let* ((lab (backend-get-next-label))
3489         (*x862-vstack* *x862-vstack*)
3490         (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)
3491         (old-stack (x862-encode-stack)))
3492    (with-x86-local-vinsn-macros (seg)
3493      (x862-open-undo $undomvexpect)
3494      (x862-undo-body seg nil (logior $backend-mvpass-mask lab) form old-stack)
3495      (@ lab))))
3496
3497(defun x862-afunc-lfun-ref (afunc)
3498  (or
3499   (afunc-lfun afunc)
3500   (progn (pushnew afunc (afunc-fwd-refs *x862-cur-afunc*) :test #'eq)
3501          afunc)))
3502
3503(defun x862-augment-arglist (afunc arglist &optional (maxregs *x862-target-num-arg-regs*))
3504  (let ((inherited-args (afunc-inherited-vars afunc)))
3505    (when inherited-args
3506      (let* ((current-afunc *x862-cur-afunc*)
3507             (stkargs (car arglist))
3508             (regargs (cadr arglist))
3509             (inhforms nil)
3510             (numregs (length regargs))
3511             (own-inhvars (afunc-inherited-vars current-afunc)))
3512        (dolist (var inherited-args)
3513          (let* ((root-var (nx-root-var var))
3514                 (other-guy 
3515                  (dolist (v own-inhvars #|(error "other guy not found")|# root-var)
3516                    (when (eq root-var (nx-root-var v)) (return v)))))
3517            (push (make-acode (%nx1-operator inherited-arg) other-guy) inhforms)))
3518        (dolist (form inhforms)
3519          (if (%i< numregs maxregs)
3520            (progn
3521              (setq regargs (nconc regargs (list form)))
3522              (setq numregs (%i+ numregs 1)))
3523            (push form stkargs)))
3524        (%rplaca (%cdr arglist) regargs) ; might have started out NIL.
3525        (%rplaca arglist stkargs)))) 
3526  arglist)
3527
3528(defun x862-acode-operator-supports-u8 (form)
3529  (setq form (acode-unwrapped-form form))
3530  (when (acode-p form)
3531    (let* ((operator (acode-operator form)))
3532      (if (member operator *x862-operator-supports-u8-target*)
3533        (values operator (acode-operand 1 form))))))
3534
3535(defun x862-acode-operator-supports-push (form)
3536  (setq form (acode-unwrapped-form form))
3537  (when (acode-p form)
3538    (if (or (eq form *nx-t*)
3539            (eq form *nx-nil*)
3540            (let* ((operator (acode-operator form)))
3541              (member operator *x862-operator-supports-push*)))
3542        form)))
3543
3544(defun x862-compare-u8 (seg vreg xfer form u8constant cr-bit true-p u8-operator)
3545  (with-x86-local-vinsn-macros (seg vreg xfer)
3546    (with-imm-target () (u8 :u8)
3547      (if (and (eql u8-operator (%nx1-operator lisptag))
3548               (eql 0 u8constant))
3549        (let* ((formreg (x862-one-untargeted-reg-form seg form *x862-arg-z*)))
3550         
3551          (! set-flags-from-lisptag formreg))
3552        (progn
3553          (x862-use-operator u8-operator seg u8 nil form)
3554          (if (zerop u8constant)
3555            (! compare-u8-reg-to-zero u8)
3556            (! compare-u8-constant u8 u8constant))))
3557      ;; Flags set.  Branch or return a boolean value ?
3558      (setq cr-bit (x862-cr-bit-for-unsigned-comparison cr-bit))
3559      (regspec-crf-gpr-case 
3560       (vreg dest)
3561       (^ cr-bit true-p)
3562       (progn
3563         (ensuring-node-target (target dest)
3564           (if (not true-p)
3565             (setq cr-bit (logxor 1 cr-bit)))
3566           (! cr-bit->boolean target cr-bit))
3567         (^))))))
3568
3569;;; There are other cases involving constants that are worth exploiting.
3570(defun x862-compare (seg vreg xfer i j cr-bit true-p)
3571  (with-x86-local-vinsn-macros (seg vreg xfer)
3572    (let* ((iu8 (let* ((i-fixnum (acode-fixnum-form-p i)))
3573                  (if (typep i-fixnum '(unsigned-byte 8))
3574                    i-fixnum)))
3575           (ju8 (let* ((j-fixnum (acode-fixnum-form-p j)))
3576                  (if (typep j-fixnum '(unsigned-byte 8))
3577                    j-fixnum)))
3578           (u8 (or iu8 ju8))
3579           (other-u8 (if iu8 j (if ju8 i)))
3580           (js32 (acode-s32-constant-p j))
3581           (is32 (acode-s32-constant-p i))
3582           (boolean (backend-crf-p vreg)))
3583      (multiple-value-bind (u8-operator u8-operand) (if other-u8 (x862-acode-operator-supports-u8 other-u8))
3584        (if u8-operator
3585          (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)
3586          (if (and boolean (or js32 is32))
3587            (let* ((reg (x862-one-untargeted-reg-form seg (if js32 i j) *x862-arg-z*))
3588                   (constant (or js32 is32)))
3589              (if (zerop constant)
3590                (! compare-reg-to-zero reg)
3591                (! compare-s32-constant reg (or js32 is32)))
3592              (unless (or js32 (eq cr-bit x86::x86-e-bits))
3593                (setq cr-bit (x862-reverse-cr-bit cr-bit)))
3594              (^ cr-bit true-p))
3595            (if (and ;(eq cr-bit x86::x86-e-bits)
3596                     (or js32 is32))
3597              (progn
3598                (unless (or js32 (eq cr-bit x86::x86-e-bits))
3599                  (setq cr-bit (x862-reverse-cr-bit cr-bit)))
3600              (x862-test-reg-%izerop
3601               seg 
3602               vreg 
3603               xfer 
3604               (x862-one-untargeted-reg-form 
3605                seg 
3606                (if js32 i j) 
3607                *x862-arg-z*) 
3608               cr-bit 
3609               true-p 
3610               (or js32 is32)))
3611              (multiple-value-bind (ireg jreg) (x862-two-untargeted-reg-forms seg i *x862-arg-y* j *x862-arg-z*)
3612                (x862-compare-registers seg vreg xfer ireg jreg cr-bit true-p)))))))))
3613
3614(defun x862-natural-compare (seg vreg xfer i j cr-bit true-p)
3615  (with-x86-local-vinsn-macros (seg vreg xfer)
3616    (let* ((jconstant (acode-fixnum-form-p j))
3617           (ju31 (typep jconstant '(unsigned-byte 31)))
3618           (iconstant (acode-fixnum-form-p i))
3619           (iu31 (typep iconstant '(unsigned-byte 31)))
3620           (boolean (backend-crf-p vreg)))
3621      (if (and boolean (or ju31 iu31))
3622        (with-imm-target
3623            () (reg :natural)
3624            (x862-one-targeted-reg-form seg (if ju31 i j) reg)
3625            (! compare-u31-constant reg (if ju31 jconstant iconstant))
3626            (unless (or ju31 (eq cr-bit x86::x86-e-bits)) 
3627                (setq cr-bit (x862-reverse-cr-bit cr-bit)))
3628            (^ cr-bit true-p))
3629        (with-imm-target () (ireg :natural)
3630          (with-additional-imm-reg ()
3631            (with-imm-target
3632                (ireg) (jreg :natural)
3633                (x862-two-targeted-reg-forms seg i ireg j jreg)
3634                (x862-compare-natural-registers seg vreg xfer ireg jreg cr-bit true-p))))))))
3635
3636
3637(defun x862-cr-bit-for-logical-comparison (cr-bit true-p)
3638  (declare (fixnum cr-bit))
3639  (let* ((unsigned
3640          (case cr-bit
3641            (#.x86::x86-l-bits x86::x86-b-bits)
3642            (#.x86::x86-le-bits x86::x86-be-bits )
3643            (#.x86::x86-g-bits x86::x86-a-bits)
3644            (#.x86::x86-ge-bits x86::x86-ae-bits)
3645            (t cr-bit))))
3646    (declare (fixnum unsigned))
3647    (if true-p
3648      unsigned
3649      (logxor unsigned 1))))
3650                 
3651(defun x862-compare-natural-registers (seg vreg xfer ireg jreg cr-bit true-p)
3652  (with-x86-local-vinsn-macros (seg vreg xfer)
3653    (if vreg
3654      (progn
3655        (setq cr-bit (x862-cr-bit-for-logical-comparison cr-bit true-p))
3656        (! compare ireg jreg)
3657        (regspec-crf-gpr-case 
3658         (vreg dest)
3659         (^ cr-bit true-p)
3660         (progn
3661           (ensuring-node-target (target dest)
3662             (! cr-bit->boolean target cr-bit))
3663           (^))))
3664      (^))))
3665
3666
3667(defun x862-compare-registers (seg vreg xfer ireg jreg cr-bit true-p)
3668  (with-x86-local-vinsn-macros (seg vreg xfer)
3669    (if vreg
3670      (progn
3671        (! compare ireg jreg)
3672        (regspec-crf-gpr-case 
3673         (vreg dest)
3674         (^ cr-bit true-p)
3675         (progn
3676           (ensuring-node-target (target dest)
3677             (if (not true-p)
3678               (setq cr-bit (logxor 1 cr-bit)))
3679             (! cr-bit->boolean target cr-bit))
3680           (^))))
3681      (^))))
3682
3683(defun x862-compare-register-to-constant (seg vreg xfer ireg cr-bit true-p constant)
3684  (cond ((eq constant *nx-nil*)
3685         (x862-compare-register-to-nil seg vreg xfer ireg cr-bit true-p))
3686        (t
3687         (with-x86-local-vinsn-macros (seg vreg xfer)
3688           (when vreg
3689             (if (eq constant *nx-t*)
3690               (! compare-to-t ireg)
3691               (let* ((imm (x862-immediate-operand constant))
3692                      (reg (x862-register-constant-p imm))) 
3693                 (if reg
3694                   (! compare-registers reg ireg)
3695                   (! compare-constant-to-register (x86-immediate-label imm) ireg))))
3696             (regspec-crf-gpr-case 
3697              (vreg dest)
3698              (^ cr-bit true-p)
3699              (progn
3700                (ensuring-node-target (target dest)
3701                  (if (not true-p)
3702                    (setq cr-bit (logxor 1 cr-bit)))
3703                  (! cr-bit->boolean target cr-bit))
3704                (^))))))))
3705         
3706(defun x862-compare-register-to-nil (seg vreg xfer ireg cr-bit true-p)
3707  (with-x86-local-vinsn-macros (seg vreg xfer)
3708    (when vreg
3709      (! compare-to-nil ireg)
3710      (regspec-crf-gpr-case 
3711       (vreg dest)
3712       (^ cr-bit true-p)
3713       (progn
3714       (ensuring-node-target (target dest)
3715         (if (not true-p)
3716           (setq cr-bit (logxor 1 cr-bit)))
3717         (! cr-bit->boolean target cr-bit))
3718       (^))))))
3719
3720(defun x862-compare-ea-to-nil (seg vreg xfer ea cr-bit true-p)
3721  (with-x86-local-vinsn-macros (seg vreg xfer)
3722    (when vreg
3723      (if (addrspec-vcell-p ea)
3724        (with-node-target () temp
3725          (x862-stack-to-register seg ea temp)
3726          (! compare-value-cell-to-nil temp))
3727        (! compare-vframe-offset-to-nil (memspec-frame-address-offset ea) *x862-vstack*))
3728      (regspec-crf-gpr-case 
3729       (vreg dest)
3730       (^ cr-bit true-p)
3731       (progn
3732       (ensuring-node-target (target dest)
3733         (if (not true-p)
3734           (setq cr-bit (logxor 1 cr-bit)))
3735         (! cr-bit->boolean target cr-bit))
3736       (^))))))
3737
3738(defun x862-cr-bit-for-unsigned-comparison (cr-bit)
3739  (ecase cr-bit
3740    (#.x86::x86-e-bits #.x86::x86-e-bits)
3741    (#.x86::x86-ne-bits #.x86::x86-ne-bits)
3742    (#.x86::x86-l-bits #.x86::x86-b-bits)
3743    (#.x86::x86-le-bits #.x86::x86-be-bits)
3744    (#.x86::x86-ge-bits #.x86::x86-ae-bits)
3745    (#.x86::x86-g-bits #.x86::x86-a-bits)))
3746
3747
3748(defun x862-compare-double-float-registers (seg vreg xfer ireg jreg cr-bit true-p)
3749  (with-x86-local-vinsn-macros (seg vreg xfer)
3750    (if vreg
3751      (progn
3752        (setq cr-bit (x862-cr-bit-for-unsigned-comparison cr-bit))
3753        (regspec-crf-gpr-case 
3754         (vreg dest)
3755         (progn
3756           (! double-float-compare ireg jreg)
3757           (^ cr-bit true-p))
3758         (progn
3759           (! double-float-compare ireg jreg)
3760           (ensuring-node-target (target dest)
3761             (if (not true-p)
3762               (setq cr-bit (logxor 1 cr-bit)))
3763             (! cr-bit->boolean target cr-bit))
3764           (^))))
3765      (^))))
3766
3767(defun x862-compare-single-float-registers (seg vreg xfer ireg jreg cr-bit true-p)
3768  (with-x86-local-vinsn-macros (seg vreg xfer)
3769    (if vreg
3770      (progn
3771        (setq cr-bit (x862-cr-bit-for-unsigned-comparison cr-bit))
3772        (regspec-crf-gpr-case 
3773         (vreg dest)
3774         (progn
3775           (! single-float-compare ireg jreg)
3776           (^ cr-bit true-p))
3777         (progn
3778           (! single-float-compare ireg jreg)
3779           (ensuring-node-target (target dest)
3780             (if (not true-p)
3781               (setq cr-bit (logxor 1 cr-bit)))
3782             (! cr-bit->boolean target cr-bit))
3783         (^))))
3784      (^))))
3785
3786
3787(defun x862-immediate-form-p (form)
3788  (if (and (consp form)
3789           (or (eq (%car form) (%nx1-operator immediate))
3790               (eq (%car form) (%nx1-operator simple-function))))
3791    t))
3792
3793(defun x862-test-%izerop (seg vreg xfer form cr-bit true-p)
3794  (x862-test-reg-%izerop seg vreg xfer (x862-one-untargeted-reg-form seg form *x862-arg-z*) cr-bit true-p 0))
3795
3796(defun x862-test-reg-%izerop (seg vreg xfer reg cr-bit true-p  zero)
3797  (declare (fixnum reg zero))
3798  (with-x86-local-vinsn-macros (seg vreg xfer)
3799    (if (zerop zero)
3800      (! compare-reg-to-zero reg)
3801      (! compare-s32-constant reg zero))
3802    (regspec-crf-gpr-case 
3803     (vreg dest)
3804     (^ cr-bit true-p)
3805     (progn
3806       (ensuring-node-target (target dest)
3807         (if (not true-p)
3808           (setq cr-bit (logxor 1 cr-bit)))
3809         (! cr-bit->boolean target cr-bit))
3810       (^)))))
3811
3812(defun x862-lexical-reference-ea (form &optional (no-closed-p t))
3813  (when (acode-p (setq form (acode-unwrapped-form form)))
3814    (if (eq (acode-operator form) (%nx1-operator lexical-reference))
3815      (let* ((addr (var-ea (%cadr form))))
3816        (if (typep addr 'lreg)
3817          addr
3818          (unless (and no-closed-p (addrspec-vcell-p addr ))
3819            addr))))))
3820
3821
3822(defun x862-vpush-register (seg src &optional why info attr)
3823  (with-x86-local-vinsn-macros (seg)
3824    (prog1
3825      (! vpush-register src)
3826      (setq *x862-tos-reg* src)
3827      (x862-new-vstack-lcell (or why :node) *x862-target-lcell-size* (or attr 0) info)
3828      (x862-adjust-vstack *x862-target-node-size*))))
3829
3830
3831;;; Need to track stack usage when pushing label for mv-call.
3832(defun x862-vpush-label (seg label)
3833  (with-x86-local-vinsn-macros (seg)
3834    (prog1
3835      (! vpush-label label)
3836      (x862-new-vstack-lcell :label *x862-target-lcell-size* 0 nil)
3837      (x862-adjust-vstack *x862-target-node-size*))))
3838
3839(defun x862-temp-push-node (seg reg)
3840  (with-x86-local-vinsn-macros (seg)
3841    (! temp-push-node reg)
3842    (x862-open-undo $undostkblk)))
3843
3844(defun x862-temp-pop-node (seg reg)
3845  (with-x86-local-vinsn-macros (seg)
3846    (! temp-pop-node reg)
3847    (x862-close-undo)))
3848
3849(defun x862-vpush-register-arg (seg src)
3850  (x862-vpush-register seg src :outgoing-argument))
3851
3852
3853(defun x862-vpop-register (seg dest)
3854  (with-x86-local-vinsn-macros (seg)
3855    (prog1
3856      (! vpop-register dest)
3857      (setq *x862-top-vstack-lcell* (lcell-parent *x862-top-vstack-lcell*))
3858      (x862-adjust-vstack (- *x862-target-node-size*)))))
3859
3860(defun x862-macptr->heap (seg dest src)
3861  (with-x86-local-vinsn-macros (seg)
3862    (! setup-macptr-allocation src)
3863    (! %allocate-uvector dest)
3864    (! %set-new-macptr-value dest)))
3865
3866(defun x862-copy-register (seg dest src)
3867  (with-x86-local-vinsn-macros (seg)
3868    (when dest
3869      (let* ((dest-gpr (backend-ea-physical-reg dest hard-reg-class-gpr))
3870             (src-gpr (if src (backend-ea-physical-reg src hard-reg-class-gpr)))
3871             (dest-fpr (backend-ea-physical-reg dest hard-reg-class-fpr))
3872             (src-fpr (if src (backend-ea-physical-reg src hard-reg-class-fpr)))
3873             (src-mode (if src (get-regspec-mode src)))
3874             (dest-mode (get-regspec-mode dest))
3875             (dest-crf (backend-ea-physical-reg dest hard-reg-class-crf)))
3876        (if (null src)
3877          (if dest-gpr
3878            (! load-nil dest-gpr)
3879            (if dest-crf
3880              (! set-eq-bit)))
3881          (if (and dest-crf src-gpr)
3882            ;; "Copying" a GPR to a CR field means comparing it to rnil
3883            (! compare-to-nil src)
3884            (if (and dest-gpr src-gpr)
3885              (if (eq src-mode dest-mode)
3886                (unless (eq src-gpr dest-gpr)
3887                  (! copy-gpr dest src))
3888                ;; This is the "GPR <- GPR" case.  There are
3889                ;; word-size dependencies, but there's also
3890                ;; lots of redundancy here.
3891                (target-arch-case
3892                 (:x8632
3893                  (ecase dest-mode
3894                    (#.hard-reg-class-gpr-mode-node ; boxed result.
3895                     (case src-mode
3896                       (#.hard-reg-class-gpr-mode-node
3897                        (unless (eql  dest-gpr src-gpr)
3898                          (! copy-gpr dest src)))
3899                       (#.hard-reg-class-gpr-mode-u32
3900                        (x862-box-u32 seg dest src))
3901                       (#.hard-reg-class-gpr-mode-s32
3902                        (x862-box-s32 seg dest src))
3903                       (#.hard-reg-class-gpr-mode-u16
3904                        (! box-fixnum dest src))
3905                       (#.hard-reg-class-gpr-mode-s16
3906                        (! box-fixnum dest src))
3907                       (#.hard-reg-class-gpr-mode-u8
3908                        (! box-fixnum dest src))
3909                       (#.hard-reg-class-gpr-mode-s8
3910                        (! box-fixnum dest src))
3911                       (#.hard-reg-class-gpr-mode-address
3912                        (x862-macptr->heap seg dest src))))
3913                    ((#.hard-reg-class-gpr-mode-u32
3914                      #.hard-reg-class-gpr-mode-address)
3915                     (case src-mode
3916                       (#.hard-reg-class-gpr-mode-node
3917                        (let* ((src-type (get-node-regspec-type-modes src)))
3918                          (declare (fixnum src-type))
3919                          (case dest-mode
3920                            (#.hard-reg-class-gpr-mode-u32
3921                             (! unbox-u32 dest src))
3922                            (#.hard-reg-class-gpr-mode-address
3923                             (unless (or (logbitp #.hard-reg-class-gpr-mode-address src-type)
3924                                         *x862-reckless*)
3925                               (! trap-unless-macptr src))
3926                             (! deref-macptr dest src)))))
3927                       ((#.hard-reg-class-gpr-mode-u32
3928                         #.hard-reg-class-gpr-mode-s32
3929                         #.hard-reg-class-gpr-mode-address)
3930                        (unless (eql  dest-gpr src-gpr)
3931                          (! copy-gpr dest src)))
3932                       (#.hard-reg-class-gpr-mode-u16
3933                        (! u16->u32 dest src))                 
3934                       (#.hard-reg-class-gpr-mode-s16
3935                        (! s16->s32 dest src))
3936                       (#.hard-reg-class-gpr-mode-u8
3937                        (! u8->u32 dest src))
3938                       (#.hard-reg-class-gpr-mode-s8
3939                        (! s8->s32 dest src))))
3940                    (#.hard-reg-class-gpr-mode-s32
3941                     (case src-mode
3942                       (#.hard-reg-class-gpr-mode-node
3943                        (! unbox-s32 dest src))
3944                       ((#.hard-reg-class-gpr-mode-u32
3945                         #.hard-reg-class-gpr-mode-s32
3946                         #.hard-reg-class-gpr-mode-address)
3947                        (unless (eql  dest-gpr src-gpr)
3948                          (! copy-gpr dest src)))
3949                       (#.hard-reg-class-gpr-mode-u16
3950                        (! u16->u32 dest src))                 
3951                       (#.hard-reg-class-gpr-mode-s16
3952                        (! s16->s32 dest src))
3953                       (#.hard-reg-class-gpr-mode-u8
3954                        (! u8->u32 dest src))
3955                       (#.hard-reg-class-gpr-mode-s8
3956                        (! s8->s32 dest src))))
3957                    (#.hard-reg-class-gpr-mode-u16
3958                     (case src-mode
3959                       (#.hard-reg-class-gpr-mode-node
3960                        (! unbox-u16 dest src))
3961                       ((#.hard-reg-class-gpr-mode-u8
3962                         #.hard-reg-class-gpr-mode-s8)
3963                        (! u8->u32 dest src))
3964                       (t
3965                        (unless (eql dest-gpr src-gpr)
3966                          (! copy-gpr dest src)))))
3967                    (#.hard-reg-class-gpr-mode-s16
3968                     (case src-mode
3969                       (#.hard-reg-class-gpr-mode-node
3970                        (! unbox-s16 dest src))
3971                       (#.hard-reg-class-gpr-mode-s8
3972                        (! s8->s32 dest src))
3973                       (#.hard-reg-class-gpr-mode-u8
3974                        (! u8->u32 dest src))
3975                       (t
3976                        (unless (eql dest-gpr src-gpr)
3977                          (! copy-gpr dest src)))))
3978                    (#.hard-reg-class-gpr-mode-u8
3979                     (case src-mode
3980                       (#.hard-reg-class-gpr-mode-node
3981                        (if *x862-reckless*
3982                          (! %unbox-u8 dest src)
3983                          (! unbox-u8 dest src)))
3984                       (t
3985                        (unless (eql dest-gpr src-gpr)
3986                          (! copy-gpr dest src)))))
3987                    (#.hard-reg-class-gpr-mode-s8
3988                     (case src-mode
3989                       (#.hard-reg-class-gpr-mode-node
3990                        (! unbox-s8 dest src))
3991                       (t
3992                        (unless (eql dest-gpr src-gpr)
3993                          (! copy-gpr dest src)))))))
3994                 (:x8664
3995                  (ecase dest-mode
3996                    (#.hard-reg-class-gpr-mode-node ; boxed result.
3997                     (case src-mode
3998                       (#.hard-reg-class-gpr-mode-node
3999                        (unless (eql  dest-gpr src-gpr)
4000                          (! copy-gpr dest src)))
4001                       (#.hard-reg-class-gpr-mode-u64
4002                        (x862-box-u64 seg dest src))
4003                       (#.hard-reg-class-gpr-mode-s64
4004                        (x862-box-s64 seg dest src))
4005                       (#.hard-reg-class-gpr-mode-u32
4006                        (x862-box-u32 seg dest src))
4007                       (#.hard-reg-class-gpr-mode-s32
4008                        (x862-box-s32 seg dest src))
4009                       (#.hard-reg-class-gpr-mode-u16
4010                        (! box-fixnum dest src))
4011                       (#.hard-reg-class-gpr-mode-s16
4012                        (! box-fixnum dest src))
4013                       (#.hard-reg-class-gpr-mode-u8
4014                        (! box-fixnum dest src))
4015                       (#.hard-reg-class-gpr-mode-s8
4016                        (! box-fixnum dest src))
4017                       (#.hard-reg-class-gpr-mode-address
4018                        (x862-macptr->heap seg dest src))))
4019                    ((#.hard-reg-class-gpr-mode-u64
4020                      #.hard-reg-class-gpr-mode-address)
4021                     (case src-mode
4022                       (#.hard-reg-class-gpr-mode-node
4023                        (let* ((src-type (get-node-regspec-type-modes src)))
4024                          (declare (fixnum src-type))
4025                          (case dest-mode
4026                            (#.hard-reg-class-gpr-mode-u64
4027                             (! unbox-u64 dest src))
4028                            (#.hard-reg-class-gpr-mode-address
4029                             (unless (or (logbitp #.hard-reg-class-gpr-mode-address src-type)
4030                                         *x862-reckless*)
4031                               (! trap-unless-macptr src))
4032                             (! deref-macptr dest src)))))
4033                       ((#.hard-reg-class-gpr-mode-u64
4034                         #.hard-reg-class-gpr-mode-s64
4035                         #.hard-reg-class-gpr-mode-address)
4036                        (unless (eql  dest-gpr src-gpr)
4037                          (! copy-gpr dest src)))
4038                       ((#.hard-reg-class-gpr-mode-u16
4039                         #.hard-reg-class-gpr-mode-s16)
4040                        (! u16->u32 dest src))
4041                       ((#.hard-reg-class-gpr-mode-u8
4042                         #.hard-reg-class-gpr-mode-s8)
4043                        (! u8->u32 dest src))))
4044                    (#.hard-reg-class-gpr-mode-s64
4045                     (case src-mode
4046                       (#.hard-reg-class-gpr-mode-node
4047                        (! unbox-s64 dest src))
4048                       ((#.hard-reg-class-gpr-mode-u64
4049                         #.hard-reg-class-gpr-mode-s64
4050                         #.hard-reg-class-gpr-mode-address)
4051                        (unless (eql  dest-gpr src-gpr)
4052                          (! copy-gpr dest src)))
4053                       ((#.hard-reg-class-gpr-mode-u16
4054                         #.hard-reg-class-gpr-mode-s16)
4055                        (! s16->s32 dest src))
4056                       ((#.hard-reg-class-gpr-mode-u8
4057                         #.hard-reg-class-gpr-mode-s8)
4058                        (! s8->s32 dest src))))
4059                    (#.hard-reg-class-gpr-mode-s32
4060                     (case src-mode
4061                       (#.hard-reg-class-gpr-mode-node
4062                        (! unbox-s32 dest src))
4063                       ((#.hard-reg-class-gpr-mode-u32
4064                         #.hard-reg-class-gpr-mode-s32
4065                         #.hard-reg-class-gpr-mode-address)
4066                        (unless (eql  dest-gpr src-gpr)
4067                          (! copy-gpr dest src)))
4068                       (#.hard-reg-class-gpr-mode-u16
4069                        (! u16->u32 dest src))                 
4070                       (#.hard-reg-class-gpr-mode-s16
4071                        (! s16->s32 dest src))
4072                       (#.hard-reg-class-gpr-mode-u8
4073                        (! u8->u32 dest src))
4074                       (#.hard-reg-class-gpr-mode-s8
4075                        (! s8->s32 dest src))))
4076                    (#.hard-reg-class-gpr-mode-u32
4077                     (case src-mode
4078                       (#.hard-reg-class-gpr-mode-node
4079                        (if *x862-reckless*
4080                          (! %unbox-u32 dest src)
4081                          (! unbox-u32 dest src)))
4082                       ((#.hard-reg-class-gpr-mode-u32
4083                         #.hard-reg-class-gpr-mode-s32)
4084                        (unless (eql  dest-gpr src-gpr)
4085                          (! copy-gpr dest src)))
4086                       (#.hard-reg-class-gpr-mode-u16
4087                        (! u16->u32 dest src))                 
4088                       (#.hard-reg-class-gpr-mode-s16
4089                        (! s16->s32 dest src))
4090                       (#.hard-reg-class-gpr-mode-u8
4091                        (! u8->u32 dest src))
4092                       (#.hard-reg-class-gpr-mode-s8
4093                        (! s8->s32 dest src))))
4094                    (#.hard-reg-class-gpr-mode-u16
4095                     (case src-mode
4096                       (#.hard-reg-class-gpr-mode-node
4097                        (if *x862-reckless*
4098                          (! %unbox-u16 dest src)
4099                          (! unbox-u16 dest src)))
4100                       ((#.hard-reg-class-gpr-mode-u8
4101                         #.hard-reg-class-gpr-mode-s8)
4102                        (! u8->u32 dest src))
4103                       (t
4104                        (unless (eql dest-gpr src-gpr)
4105                          (! copy-gpr dest src)))))
4106                    (#.hard-reg-class-gpr-mode-s16
4107                     (case src-mode
4108                       (#.hard-reg-class-gpr-mode-node
4109                        (! unbox-s16 dest src))
4110                       (#.hard-reg-class-gpr-mode-s8
4111                        (! s8->s32 dest src))
4112                       (#.hard-reg-class-gpr-mode-u8
4113                        (! u8->u32 dest src))
4114                       (t
4115                        (unless (eql dest-gpr src-gpr)
4116                          (! copy-gpr dest src)))))
4117                    (#.hard-reg-class-gpr-mode-u8
4118                     (case src-mode
4119                       (#.hard-reg-class-gpr-mode-node
4120                        (if *x862-reckless*
4121                          (! %unbox-u8 dest src)
4122                          (! unbox-u8 dest src)))
4123                       (t
4124                        (unless (eql dest-gpr src-gpr)
4125                          (! copy-gpr dest src)))))
4126                    (#.hard-reg-class-gpr-mode-s8
4127                     (case src-mode
4128                       (#.hard-reg-class-gpr-mode-node
4129                        (! unbox-s8 dest src))
4130                       (t
4131                        (unless (eql dest-gpr src-gpr)
4132                          (! copy-gpr dest src)))))))))
4133              (if src-gpr
4134                (if dest-fpr
4135                  (progn
4136                    (case src-mode
4137                      (#.hard-reg-class-gpr-mode-node
4138                       (case dest-mode
4139                         (#.hard-reg-class-fpr-mode-double
4140                          (unless (or (logbitp hard-reg-class-fpr-type-double 
4141                                           (get-node-regspec-type-modes src))
4142                                      *x862-reckless*)
4143                            (! trap-unless-double-float src))
4144                          (! get-double dest src))
4145                         (#.hard-reg-class-fpr-mode-single
4146                          (unless *x862-reckless* (! trap-unless-single-float src))
4147                          (! get-single dest src)))))))
4148                (if dest-gpr
4149                  (case dest-mode
4150                    (#.hard-reg-class-gpr-mode-node
4151                     (case src-mode
4152                       (#.hard-reg-class-fpr-mode-double
4153                        (x862-double->heap seg dest src))
4154                       (#.hard-reg-class-fpr-mode-single
4155                        (target-arch-case
4156                         (:x8632
4157                          (x862-single->heap seg dest src))
4158                         (:x8664
4159                          (! single->node dest src)))))))
4160                  (if (and src-fpr dest-fpr)
4161                    (unless (eql dest-fpr src-fpr)
4162                      (if (= src-mode hard-reg-class-fpr-mode-double)
4163                        (if (= dest-mode hard-reg-class-fpr-mode-double)
4164                          (! copy-double-float dest src)
4165                          (! copy-double-to-single dest src))
4166                        (if (= dest-mode hard-reg-class-fpr-mode-double)
4167                          (! copy-single-to-double dest src)
4168                          (! copy-single-float dest src))))))))))))))
4169 
4170(defun x862-unreachable-store (&optional vreg)
4171  ;; I don't think that anything needs to be done here,
4172  ;; but leave this guy around until we're sure.
4173  ;; (X862-VPUSH-REGISTER will always vpush something, even
4174  ;; if code to -load- that "something" never gets generated.
4175  ;; If I'm right about this, that means that the compile-time
4176  ;; stack-discipline problem that this is supposed to deal
4177  ;; with can't happen.)
4178  (declare (ignore vreg))
4179  nil)
4180
4181;;; bind vars to initforms, as per let*, &aux.
4182(defun x862-seq-bind (seg vars initforms)
4183  (dolist (var vars)
4184    (x862-seq-bind-var seg var (pop initforms))))
4185
4186(defun x862-target-is-imm-subtag (subtag)
4187  (when subtag
4188    (target-arch-case
4189     (:x8632
4190      (let* ((masked (logand subtag x8632::fulltagmask)))
4191        (declare (fixnum masked))
4192        (= masked x8632::fulltag-immheader)))
4193     (:x8664
4194      (let* ((masked (logand subtag x8664::fulltagmask)))
4195        (declare (fixnum masked))
4196        (or (= masked x8664::fulltag-immheader-0)
4197            (= masked x8664::fulltag-immheader-1)
4198            (= masked x8664::fulltag-immheader-2)))))))
4199
4200(defun x862-target-is-node-subtag (subtag)
4201  (when subtag
4202    (target-arch-case
4203     (:x8632
4204      (let* ((masked (logand subtag x8632::fulltagmask)))
4205        (declare (fixnum masked))
4206        (= masked x8632::fulltag-nodeheader)))
4207     (:x8664
4208      (let* ((masked (logand subtag x8664::fulltagmask)))
4209        (declare (fixnum masked))
4210        (or (= masked x8664::fulltag-nodeheader-0)
4211            (= masked x8664::fulltag-nodeheader-1)))))))
4212
4213(defun x862-dynamic-extent-form (seg curstack val)
4214  (when (acode-p val)
4215    (with-x86-local-vinsn-macros (seg)
4216      (let* ((op (acode-operator val)))
4217        (cond ((eq op (%nx1-operator list))
4218               (let* ((*x862-vstack* *x862-vstack*)
4219                      (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
4220                 (x862-set-nargs seg (x862-formlist seg (%cadr val) nil))
4221                 (x862-open-undo $undostkblk curstack)
4222                 (! stack-cons-list))
4223               (setq val *x862-arg-z*))
4224              ((eq op (%nx1-operator list*))
4225               (let* ((arglist (%cadr val)))                   
4226                 (let* ((*x862-vstack* *x862-vstack*)
4227                        (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
4228                   (x862-formlist seg (car arglist) (cadr arglist)))
4229                 (when (car arglist)
4230                   (x862-set-nargs seg (length (%car arglist)))
4231                   (! stack-cons-list*)
4232                   (x862-open-undo $undostkblk curstack))
4233                 (setq val *x862-arg-z*)))
4234              ((eq op (%nx1-operator multiple-value-list))
4235               (x862-multiple-value-body seg (%cadr val))
4236               (x862-open-undo $undostkblk curstack)
4237               (! stack-cons-list)
4238               (setq val *x862-arg-z*))
4239              ((eq op (%nx1-operator cons))
4240               (let* ((y ($ *x862-arg-y*))
4241                      (z ($ *x862-arg-z*))
4242                      (result ($ *x862-arg-z*)))
4243                 (x862-two-targeted-reg-forms seg (%cadr val) y (%caddr val) z)
4244                 (x862-open-undo $undostkblk )
4245                 (! make-tsp-cons result y z) 
4246                 (setq val result)))
4247              ((eq op (%nx1-operator %consmacptr%))
4248               (with-imm-target () (address :address)
4249                 (x862-one-targeted-reg-form seg val address)
4250                 (with-node-target () node
4251                   (! macptr->stack node address)
4252                   (x862-open-undo $undo-x86-c-frame)
4253                   (setq val node))))
4254              ((eq op (%nx1-operator %new-ptr))
4255               (let ((clear-form (caddr val)))