source: trunk/source/compiler/ARM/arm2.lisp @ 16156

Last change on this file since 16156 was 16156, checked in by gb, 7 years ago

Spell "single" with an #\n.

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