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

Last change on this file since 16611 was 16611, checked in by gb, 6 years ago

handle LOAD-TIME-VALUE differently.
In the COMPILE (EVAL) case, wrap the literal (immediate) in new acode.
make ACODE-CONSTANT-P recognize the COMPILE-FILE case, and return NIl,NIL
Fixes ticket:1317 in the trunk

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