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

Last change on this file since 15032 was 15032, checked in by gb, 8 years ago

In X862-{THREE,FOUR}-UNTARGETED-REG-FORMS: when a destination register
is determined, resolve conflicts with any that are still pending (even
if the destination is set via possibly-elided pop.)

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