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

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

Work in progress.

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