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

Last change on this file since 15004 was 15004, checked in by gb, 9 years ago

Do some cases of CASE (and similar constructs) in constant time by
using a jump table in the x86 backends. This -seems- to do the right
things (wrt stack discipline, multiple values, etc.) in all cases that
I've tried (including a handful of things in CCL itself); it can
currently be disabled by setting CCL::*X862-GENERATE-CASEJUMP* to NIL
before compiling.

Get the x86 disassembler to recognize and display jump tables.
Persuade it to print the instruction address in a comment after the
instruction. (We're a ways from being able to re-assemble disassembled
code on x86 for several other reasons, but I think that this makes the
disassembly a little easier to read.)

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