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

Last change on this file since 9911 was 9911, checked in by gz, 11 years ago

Propagate r9253 - r9261, r9331 from trunk: If optimize quantity SAFETY is greater than SPPED, the THE special form verifies the type at runtime.

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