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

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

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

File size: 440.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 :uses-frame-pointer)
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      (let* ((vinsns (make-vinsn-list))
609             (*vinsn-list* vinsns))
610        (unwind-protect
611             (progn
612               (setq bits (arm2-toplevel-form vinsns (make-wired-lreg *arm2-result-reg*) $backend-return (afunc-acode afunc)))
613               (dotimes (i (length *backend-immediates*))
614                 (let ((imm (aref *backend-immediates* i)))
615                   (when (arm2-symbol-locative-p imm) (aset *backend-immediates* i (car imm)))))
616               (optimize-vinsns vinsns)
617               (when (logbitp arm2-debug-vinsns-bit *arm2-debug-mask*)
618                 (format t "~% vinsns for ~s (after generation)" (afunc-name afunc))
619                 (do-dll-nodes (v vinsns) (format t "~&~s" v))
620                 (format t "~%~%"))
621           
622               (with-dll-node-freelist (code arm::*lap-instruction-freelist*)
623                 (with-dll-node-freelist (data arm::*lap-instruction-freelist*)
624                   (let* ((arm::*lap-labels* nil)
625                          (sections (vector code data))
626                          debug-info)
627                     (declare (dynamic-extent sections))
628                     (arm2-expand-vinsns vinsns code sections)
629                     (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc)))
630                       (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
631                     (setq debug-info (afunc-lfun-info afunc))
632                     (when lambda-form
633                       (setq debug-info (list* 'function-lambda-expression lambda-form debug-info)))
634                     (when *arm2-recorded-symbols*
635                       (setq debug-info (list* 'function-symbol-map *arm2-recorded-symbols* debug-info)))
636                     (when (and (getf debug-info '%function-source-note) *arm2-emitted-source-notes*)
637                       (setq debug-info (list* 'pc-source-map *arm2-emitted-source-notes* debug-info)))
638                     (when debug-info
639                       (setq bits (logior (ash 1 $lfbits-info-bit) bits))
640                       (backend-new-immediate debug-info))
641                     (if (or fname lambda-form *arm2-recorded-symbols*)
642                       (backend-new-immediate fname)
643                       (setq bits (logior (ash -1 $lfbits-noname-bit) bits)))
644                     
645                     (unless (afunc-parent afunc)
646                       (arm2-fixup-fwd-refs afunc))
647                     (setf (afunc-all-vars afunc) nil)
648                     (setf (afunc-argsword afunc) bits)
649                     (setf (afunc-lfun afunc)
650                           (arm2-xmake-function
651                            code
652                            *backend-immediates*
653                            bits
654                            data))
655                     (when (getf debug-info 'pc-source-map)
656                       (setf (getf debug-info 'pc-source-map) (arm2-generate-pc-source-map debug-info)))
657                     (when (getf debug-info 'function-symbol-map)
658                       (setf (getf debug-info 'function-symbol-map) (arm2-digest-symbols))))))))))
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 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          (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)
2606                 (value (if (eql (hard-regspec-class result-reg)
2607                                 hard-reg-class-gpr)
2608                          (hard-regspec-value result-reg))))
2609            (when (and value (logbitp value *available-backend-imm-temps*))
2610              (setq *available-backend-imm-temps* (bitclr value *available-backend-imm-temps*)))
2611        (with-crf-target () crf
2612          (! set-z-if-vector-header crf src)
2613          (arm2-branch seg (arm2-make-compound-cd simple-case 0) crf arm::arm-cond-eq nil))
2614          (when safe
2615            (! trap-unless-fixnum unscaled-idx)
2616            (! check-vector-header-bound src unscaled-idx)
2617            (when (typep safe 'fixnum)
2618              (! trap-unless-vector-type src safe)))
2619          (! deref-vector-header src unscaled-idx)
2620          (-> common-case)
2621          (@ simple-case)
2622          (when safe
2623            (if (typep safe 'fixnum)
2624              (! trap-unless-simple-1d-array src safe))
2625            (! trap-unless-fixnum unscaled-idx)
2626            (! check-misc-bound unscaled-idx src))
2627          (@ common-case)
2628
2629
2630        (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))))))
2631
2632
2633(defun arm2-tail-call-alias (immref sym &optional arglist)
2634  (let ((alias (cdr (assq sym *arm2-tail-call-aliases*))))
2635    (if (and alias (or (null arglist) (eq (+ (length (car arglist)) (length (cadr arglist))) (cdr alias))))
2636      (make-acode (%nx1-operator immediate) (car alias))
2637      immref)))
2638
2639;;; If BODY is essentially an APPLY involving an &rest arg, try to avoid
2640;;; consing it.
2641(defun arm2-eliminate-&rest (body rest key-p auxen rest-values)
2642  (when (and rest (not key-p) (not (cadr auxen)) rest-values)
2643    (when (eq (logand (the fixnum (nx-var-bits rest))
2644                      (logior (ash -1 $vbitspecial)
2645                              (ash 1 $vbitclosed) (ash 1 $vbitsetq) (ash 1 $vbitcloseddownward)))
2646              0)               ; Nothing but simple references
2647      (do* ()
2648           ((not (acode-p body)))
2649        (let* ((op (acode-operator body)))
2650          (if (or (eq op (%nx1-operator lexical-function-call))
2651                  (eq op (%nx1-operator call)))
2652            (destructuring-bind (fn-form (stack-args reg-args) &optional spread-p) (acode-operands body)
2653               (unless (and (eq spread-p t)
2654                           (eq (arm2-lexical-reference-p (%car reg-args)) rest))
2655                (return nil))
2656              (flet ((independent-of-all-values (form)       
2657                       (setq form (acode-unwrapped-form-value form))
2658                       (or (arm-constant-form-p form)
2659                           (let* ((lexref (arm2-lexical-reference-p form)))
2660                             (and lexref 
2661                                  (neq lexref rest)
2662                                  (dolist (val rest-values t)
2663                                    (unless (nx2-var-not-set-by-form-p lexref val)
2664                                      (return))))))))
2665                (unless (or (eq op (%nx1-operator lexical-function-call))
2666                            (independent-of-all-values fn-form))
2667                  (return nil))
2668                (if (dolist (s stack-args t)
2669                          (unless (independent-of-all-values s)
2670                            (return nil)))
2671                  (let* ((arglist (append stack-args rest-values)))
2672                    (return
2673                     (make-acode op 
2674                                 fn-form 
2675                                 (if (<= (length arglist) $numarmargregs)
2676                                   (list nil (reverse arglist))
2677                                   (list (butlast arglist $numarmargregs)
2678                                         (reverse (last arglist $numarmargregs))))
2679                                 nil)))
2680                  (return nil))))
2681            (if (eq op (%nx1-operator local-block))
2682              (setq body (cadr (acode-operands body)))
2683              (if (and (eq op (%nx1-operator if))
2684                       (eq (arm2-lexical-reference-p (car (acode-operands body))) rest))
2685                (setq body (car (cdr (acode-operands body))))
2686                (return nil)))))))))
2687
2688(defun arm2-call-fn (seg vreg xfer fn arglist spread-p)
2689  (with-arm-local-vinsn-macros (seg vreg xfer)
2690    (when spread-p
2691      (destructuring-bind (stack-args reg-args) arglist
2692        (when (and (null (cdr reg-args))
2693                   (nx-null (acode-unwrapped-form-value (car reg-args))))
2694          (setq spread-p nil)
2695          (let* ((nargs (length stack-args)))
2696            (declare (fixnum nargs))
2697            (if (<= nargs $numarmargregs)
2698              (setq arglist (list nil (reverse stack-args)))
2699              (setq arglist (list (butlast stack-args $numarmargregs) (reverse (last stack-args $numarmargregs)))))))))
2700    (let* ((lexref (arm2-lexical-reference-p fn))
2701           (simple-case (or (fixnump fn)
2702                            (typep fn 'lreg)
2703                            (arm2-immediate-function-p fn)
2704                            (and 
2705                             lexref
2706                             (not spread-p)
2707                             (flet ((all-simple (args)
2708                                      (dolist (arg args t)
2709                                        (when (and arg (not (nx2-var-not-set-by-form-p lexref arg)))
2710                                          (return)))))
2711                               (and (all-simple (car arglist))
2712                                    (all-simple (cadr arglist))
2713                                    (setq fn (var-ea lexref)))))))
2714           (cstack *arm2-cstack*)
2715           (vstack *arm2-vstack*))
2716      (setq xfer (or xfer 0))
2717      (when (and (eq xfer $backend-return)
2718                 (eq 0 *arm2-undo-count*)
2719                 (acode-p fn)
2720                 (eq (acode-operator fn) (%nx1-operator immediate))
2721                 (symbolp (car (acode-operands fn))))
2722        (setq fn (arm2-tail-call-alias fn (car (acode-operands fn)) arglist)))
2723     
2724      (if (and (eq xfer $backend-return) (not (arm2-tailcallok xfer)))
2725        (progn
2726          (arm2-call-fn seg vreg $backend-mvpass fn arglist spread-p)
2727          (arm2-set-vstack (%i+ (if simple-case 0 *arm2-target-node-size*) vstack))
2728          (setq  *arm2-cstack* cstack)
2729          (let ((*arm2-returning-values* t)) (arm2-do-return seg)))
2730        (let* ((mv-p (arm2-mv-p xfer)))
2731          (unless simple-case
2732            (arm2-vpush-register seg (arm2-one-untargeted-reg-form seg fn arm::arg_z))
2733            (setq fn (arm2-vloc-ea vstack)))
2734          (arm2-invoke-fn seg fn (arm2-arglist seg arglist) spread-p xfer)
2735          (if (and (logbitp $backend-mvpass-bit xfer)
2736                   (not simple-case))
2737            (progn
2738              (! save-values)
2739              (! vstack-discard 1)
2740              (arm2-set-nargs seg 0)
2741              (! recover-values))
2742            (unless (or mv-p simple-case)
2743              (! vstack-discard 1)))
2744          (arm2-set-vstack vstack)
2745          (setq *arm2-cstack* cstack)
2746          (when (or (logbitp $backend-mvpass-bit xfer) (not mv-p))
2747            (<- arm::arg_z)
2748            (arm2-branch seg (logand (lognot $backend-mvpass-mask) xfer) vreg))))
2749      nil)))
2750
2751(defun arm2-restore-full-lisp-context (seg)
2752  (with-arm-local-vinsn-macros (seg)
2753    (! restore-full-lisp-context)))
2754
2755(defun arm2-call-symbol (seg jump-p)
2756  ; fname contains a symbol; we can either call it via
2757  ; a call to .SPjmpsym or expand the instructions inline.
2758  ; Since the branches are unconditional, the call doesn't
2759  ; cost much, but doing the instructions inline would give
2760  ; an instruction scheduler some opportunities to improve
2761  ; performance, so this isn't a strict time/speed tradeoff.
2762  ; This should probably dispatch on something other than
2763  ; *arm2-open-code-inline*, since that does imply a time/speed
2764  ; tradeoff.
2765  (with-arm-local-vinsn-macros (seg)
2766    (if *arm2-optimize-for-space*
2767      (if jump-p
2768        (! jump-known-symbol-ool)
2769        (! call-known-symbol-ool))
2770      (if jump-p
2771        (! jump-known-symbol)
2772        (! call-known-symbol arm::arg_z)))))
2773
2774;;; Nargs = nil -> multiple-value case.
2775(defun arm2-invoke-fn (seg fn nargs spread-p xfer)
2776  (with-arm-local-vinsn-macros (seg)
2777    (let* ((f-op (acode-unwrapped-form-value fn))
2778           (immp (and (acode-p f-op)
2779                      (eq (acode-operator f-op) (%nx1-operator immediate))))
2780           (symp (and immp (symbolp (car (acode-operands f-op)))))
2781           (label-p (and (fixnump fn) 
2782                         (locally (declare (fixnum fn))
2783                           (and (= fn -1) (- fn)))))
2784           (tail-p (eq xfer $backend-return))
2785           (func (if (acode-p f-op) (car (acode-operands f-op))))
2786           (a-reg nil)
2787           (lfunp (and (acode-p f-op) 
2788                       (eq (acode-operator f-op) (%nx1-operator simple-function))))
2789           (expression-p (or (typep fn 'lreg) (and (fixnump fn) (not label-p))))
2790           (callable (or symp lfunp label-p))
2791           (destreg (if symp ($ arm::fname) (if lfunp ($ arm::nfn) (unless label-p ($ arm::nfn)))))
2792           (known-fixed-nargs nil)
2793           (label (when label-p
2794                    (if (and *arm2-fixed-args-label*
2795                             (eql nargs *arm2-fixed-nargs*)
2796                             (not spread-p)
2797                             (not (arm2-mvpass-p xfer)))
2798                      (progn
2799                        (setq known-fixed-nargs t)
2800                        (if tail-p
2801                          *arm2-fixed-args-tail-label*
2802                          *arm2-fixed-args-label*))
2803                      1))))
2804      (when expression-p
2805        ;;Have to do this before spread args, since might be vsp-relative.
2806        (if nargs
2807          (arm2-do-lexical-reference seg destreg fn)
2808          (arm2-copy-register seg destreg fn)))
2809      (if (or symp lfunp)
2810        (setq func (if symp (arm2-symbol-entry-locative func)
2811                     (arm2-afunc-lfun-ref func))
2812              a-reg (arm2-register-constant-p func)))
2813      (when tail-p
2814        #-no-compiler-bugs
2815        (unless (or immp symp lfunp (typep fn 'lreg) (fixnump fn)) (compiler-bug "Well, well, well.  How could this have happened ?"))
2816        (when a-reg
2817          (arm2-copy-register seg destreg a-reg))
2818        (unless spread-p
2819          (arm2-restore-nvrs seg (null nargs))
2820          (arm2-restore-non-volatile-fprs seg)
2821          (! restore-nfp)))
2822      (if spread-p
2823        (progn
2824          (arm2-set-nargs seg (%i- nargs 1))
2825          (if (eq spread-p 0)
2826            (! spread-lexpr)
2827            (! spread-list))
2828          (arm2-restore-nvrs seg nil)
2829          (arm2-restore-non-volatile-fprs seg)
2830          (! restore-nfp))
2831        (if nargs
2832          (unless known-fixed-nargs (arm2-set-nargs seg nargs))
2833          (! pop-argument-registers)))
2834      (if callable
2835        (if (not tail-p)
2836          (if (arm2-mvpass-p xfer)
2837            (let* ((call-reg (if symp ($ arm::fname) ($ arm::nfn))))
2838              (if label-p
2839                (arm2-copy-register seg call-reg ($ arm::fn))
2840                (if a-reg
2841                  (arm2-copy-register seg call-reg  a-reg)
2842                  (arm2-store-immediate seg func call-reg)))
2843              (if symp
2844                (! pass-multiple-values-symbol)
2845                (! pass-multiple-values)))
2846            (progn 
2847              (if label-p
2848                (progn
2849                  (arm2-copy-register seg ($ arm::nfn) ($  arm::fn))
2850                  (! call-label (aref *backend-labels* label)))
2851                (progn
2852                  (if a-reg
2853                    (arm2-copy-register seg destreg a-reg)
2854                    (arm2-store-immediate seg func destreg))
2855                  (if symp
2856                    (arm2-call-symbol seg nil)
2857                    (! call-known-function))))))
2858          (progn
2859            (arm2-unwind-stack seg xfer 0 0 #x7fffff)
2860            (if (and (not spread-p) nargs (%i<= nargs $numarmargregs))
2861              (progn
2862                (if label-p
2863                  (unless known-fixed-nargs
2864                    (arm2-copy-register seg arm::nfn arm::fn)))
2865                (unless (or label-p a-reg) (arm2-store-immediate seg func destreg))
2866                (unless known-fixed-nargs
2867                  (arm2-restore-full-lisp-context seg))
2868                (if label-p
2869                  (! jump (aref *backend-labels* label))
2870                  (progn
2871                    (if symp
2872                      (arm2-call-symbol seg t)
2873                      (! jump-known-function)))))
2874              (progn
2875                (if label-p
2876                  (arm2-copy-register seg arm::nfn arm::fn)
2877                  (unless a-reg (arm2-store-immediate seg func destreg)))
2878                (cond ((or spread-p (null nargs))
2879                       (if symp
2880                         (! tail-call-sym-gen)
2881                         (! tail-call-fn-gen)))
2882                      ((%i> nargs $numarmargregs)
2883                       (if symp
2884                         (! tail-call-sym-slide)
2885                         (! tail-call-fn-slide)))
2886                      (t
2887                       (! restore-full-lisp-context)
2888                       (if symp
2889                         (! jump-known-symbol)
2890                         (! jump-known-function))))))))
2891        ;; The general (funcall) case: we don't know (at compile-time)
2892        ;; for sure whether we've got a symbol or a (local, constant)
2893        ;; function.
2894        (progn
2895          (unless (or (fixnump fn) (typep fn 'lreg))
2896            (arm2-one-targeted-reg-form seg fn destreg))
2897          (if (not tail-p)
2898            (if (arm2-mvpass-p xfer)
2899              (! pass-multiple-values)
2900              (! funcall))                 
2901            (cond ((or (null nargs) spread-p)
2902                   (! tail-funcall-gen))
2903                  ((%i> nargs $numarmargregs)
2904                   (! tail-funcall-slide))
2905                  (t
2906                   (! tail-funcall-vsp)))))))
2907    nil))
2908
2909(defun arm2-seq-fbind (seg vreg xfer vars afuncs body p2decls)
2910  (let* ((old-stack (arm2-encode-stack))
2911         (copy afuncs)
2912         (func nil))
2913    (with-arm-p2-declarations p2decls 
2914      (dolist (var vars) 
2915        (when (neq 0 (afunc-fn-refcount (setq func (pop afuncs))))
2916          (arm2-seq-bind-var seg var (nx1-afunc-ref func))))
2917      (arm2-undo-body seg vreg xfer body old-stack)
2918      (dolist (var vars)
2919        (when (neq 0 (afunc-fn-refcount (setq func (pop copy))))
2920          (arm2-close-var seg var))))))
2921
2922(defun arm2-make-closure (seg afunc downward-p)
2923  (with-arm-local-vinsn-macros (seg)
2924    (flet ((var-to-reg (var target)
2925             (let* ((ea (var-ea (var-bits var))))
2926               (if ea
2927                 (arm2-addrspec-to-reg seg (arm2-ea-open ea) target)
2928                 (! load-nil target))
2929               target))
2930           (set-some-cells (dest cellno c0 c1 c2 c3)
2931             (declare (fixnum cellno))
2932             (! misc-set-c-node c0 dest cellno)
2933             (incf cellno)
2934             (when c1
2935               (! misc-set-c-node c1 dest cellno)
2936               (incf cellno)
2937               (when c2
2938                 (! misc-set-c-node c2 dest cellno)
2939                 (incf cellno)
2940                 (when c3
2941                   (! misc-set-c-node c3 dest cellno)
2942                   (incf cellno))))
2943             cellno))
2944      (let* ((inherited-vars (afunc-inherited-vars afunc))
2945             (arch (backend-target-arch *target-backend*))
2946             (dest ($ arm::arg_z))
2947             (vsize (+ (length inherited-vars) 
2948                       3                ; entrypoint,%closure-code%, afunc
2949                       2)))             ; name, lfun-bits
2950        (declare (list inherited-vars))
2951        (if downward-p
2952          (progn
2953            (let* ((*arm2-vstack* *arm2-vstack*))
2954              (arm2-lri seg arm::arg_x (ash (nx-lookup-target-uvector-subtag :function) *arm2-target-fixnum-shift*))
2955              (arm2-lri seg arm::temp0 0)
2956              (! %closure-code% arm::arg_y)
2957              (arm2-store-immediate seg (arm2-afunc-lfun-ref afunc) arm::arg_z)
2958              (arm2-vpush-register-arg seg arm::arg_x)
2959              (arm2-vpush-register-arg seg arm::temp0)
2960              (arm2-vpush-register-arg seg arm::arg_y)
2961              (arm2-vpush-register-arg seg arm::arg_z)
2962              ;; Could be smarter about memory traffic here.
2963              (dolist (v inherited-vars)
2964                (arm2-vpush-register-arg seg (var-to-reg v arm::arg_z)))
2965              (! load-nil arm::arg_z)
2966              (arm2-vpush-register-arg seg arm::arg_z)
2967              (arm2-lri seg arm::arg_z (ash (ash 1 $lfbits-trampoline-bit) *arm2-target-fixnum-shift*))
2968              (arm2-vpush-register-arg seg arm::arg_z)
2969              (arm2-set-nargs seg (1+ vsize)) ; account for subtag
2970              (! make-stack-closure))
2971            (arm2-open-undo $undostkblk))
2972          (let* ((cell 1))
2973            (declare (fixnum cell))
2974            (progn
2975              (arm2-lri seg
2976                        arm::imm0
2977                        (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function)))
2978              (! %alloc-misc-fixed dest arm::imm0 (ash vsize (arch::target-word-shift arch)))
2979              )
2980            (! %closure-code% arm::arg_x)
2981            (! %codevector-entry arm::lr arm::arg_x)
2982            (! misc-set-c-node arm::lr dest 0)
2983            (arm2-store-immediate seg (arm2-afunc-lfun-ref afunc) arm::arg_y)
2984            (with-node-temps (arm::arg_z) (t0 t1 t2 t3)
2985              (do* ((ccode arm::arg_x nil)
2986                    (func arm::arg_y nil))
2987                   ((null inherited-vars))
2988                (let* ((t0r (or ccode (if inherited-vars (var-to-reg (pop inherited-vars) t0))))
2989                       (t1r (or func (if inherited-vars (var-to-reg (pop inherited-vars) t1))))
2990                       (t2r (if inherited-vars (var-to-reg (pop inherited-vars) t2)))
2991                       (t3r (if inherited-vars (var-to-reg (pop inherited-vars) t3))))
2992                  (setq cell (set-some-cells dest cell t0r t1r t2r t3r)))))
2993            (arm2-lri seg arm::arg_y (ash (ash 1 $lfbits-trampoline-bit) *arm2-target-fixnum-shift*))
2994            (! load-nil arm::arg_x)
2995            (! misc-set-c-node arm::arg_x dest cell)
2996            (! misc-set-c-node arm::arg_y dest (1+ cell))))
2997        dest))))
2998       
2999(defun arm2-symbol-entry-locative (sym)
3000  (setq sym (require-type sym 'symbol))
3001  (when (eq sym '%call-next-method-with-args)
3002    (setf (afunc-bits *arm2-cur-afunc*)
3003          (%ilogior (%ilsl $fbitnextmethargsp 1) (afunc-bits *arm2-cur-afunc*))))
3004  (or (assq sym *arm2-fcells*)
3005      (let ((new (list sym)))
3006        (push new *arm2-fcells*)
3007        new)))
3008
3009(defun arm2-symbol-value-cell (sym)
3010  (setq sym (require-type sym 'symbol))
3011  (or (assq sym *arm2-vcells*)
3012      (let ((new (list sym)))
3013        (push new *arm2-vcells*)
3014        (ensure-binding-index sym)
3015        new)))
3016
3017
3018(defun arm2-symbol-locative-p (imm)
3019  (and (consp imm)
3020       (or (memq imm *arm2-vcells*)
3021           (memq imm *arm2-fcells*))))
3022
3023
3024
3025
3026(defun arm2-immediate-function-p (f)
3027  (setq f (acode-unwrapped-form-value f))
3028  (and (acode-p f)
3029       (or (eq (acode-operator f) (%nx1-operator immediate))
3030           (eq (acode-operator f) (%nx1-operator simple-function)))))
3031
3032(defun arm-constant-form-p (form)
3033  (setq form (nx-untyped-form form))
3034  (if form
3035    (or (nx-null form)
3036        (nx-t form)
3037        (and (acode-p form)
3038             (or (eq (acode-operator form) (%nx1-operator immediate))
3039                 (eq (acode-operator form) (%nx1-operator fixnum))
3040                 (eq (acode-operator form) (%nx1-operator simple-function)))))))
3041
3042
3043 
3044(defun arm2-integer-constant-p (form mode)
3045  (let* ((val 
3046         (or (acode-fixnum-form-p (setq form (acode-unwrapped-form form)))
3047             (and (acode-p form)
3048                  (eq (acode-operator form) (%nx1-operator immediate))
3049                  (setq form (car (acode-operands form)))
3050                  (if (typep form 'integer)
3051                    form)))))
3052    (and val (%typep val (mode-specifier-type mode)) val)))
3053
3054
3055(defun arm-side-effect-free-form-p (form)
3056  (when (acode-p (setq form (acode-unwrapped-form-value form)))
3057    (unless (arm2-nfp-ref-p form)
3058      (or (arm-constant-form-p form)
3059                                        ;(eq (acode-operator form) (%nx1-operator bound-special-ref))
3060          (if (eq (acode-operator form) (%nx1-operator lexical-reference))
3061            (not (%ilogbitp $vbitsetq (nx-var-bits (car (acode-operands form))))))))))
3062
3063(defun arm2-formlist (seg stkargs &optional revregargs)
3064  (with-arm-local-vinsn-macros (seg) 
3065    (let* ((nregs (length revregargs))
3066           (n nregs))
3067      (declare (fixnum n))
3068      (dolist (arg stkargs)
3069        (let* ((reg (arm2-one-untargeted-reg-form seg arg arm::arg_z)))
3070          (arm2-vpush-register-arg seg reg)
3071          (incf n)))
3072      (when revregargs
3073        (let* ((zform (%car revregargs))
3074               (yform (%cadr revregargs))
3075               (xform (%caddr revregargs)))
3076          (if (eq 3 nregs)
3077            (arm2-three-targeted-reg-forms seg xform ($ arm::arg_x) yform ($ arm::arg_y) zform ($ arm::arg_z))
3078            (if (eq 2 nregs)
3079              (arm2-two-targeted-reg-forms seg yform ($ arm::arg_y) zform ($ arm::arg_z))
3080              (arm2-one-targeted-reg-form seg zform ($ arm::arg_z))))))
3081      n)))
3082
3083(defun arm2-arglist (seg args)
3084  (arm2-formlist seg (car args) (cadr args)))
3085
3086
3087
3088
3089
3090(defun arm2-unboxed-integer-arg-to-reg (seg form immreg &optional ffi-arg-type)
3091  (let* ((mode (case ffi-arg-type
3092                 ((nil) :natural)
3093                 (:signed-byte :s8)
3094                 (:unsigned-byte :u8)
3095                 (:signed-halfword :s16)
3096                 (:unsigned-halfword :u16)
3097                 (:signed-fullword :s32)
3098                 (:unsigned-fullword :u32)
3099                 (:unsigned-doubleword :u64)
3100                 (:signed-doubleword :s64)))
3101         (modeval (gpr-mode-name-value mode)))
3102    (with-arm-local-vinsn-macros (seg)
3103      (let* ((value (arm2-integer-constant-p form mode)))
3104        (if value
3105            (progn
3106              (unless (typep immreg 'lreg)
3107                (setq immreg (make-unwired-lreg immreg :mode modeval)))
3108              (arm2-lri seg immreg value)
3109              immreg)
3110          (progn 
3111            (arm2-one-targeted-reg-form seg form (make-wired-lreg arm::imm0 :mode modeval))))))))
3112
3113
3114(defun arm2-macptr-arg-to-reg (seg form address-reg) 
3115  (arm2-one-targeted-reg-form seg
3116                              form 
3117                              address-reg))
3118
3119(defun arm2-push-reg-for-form (seg form suggested &optional targeted)
3120  (let* ((reg (if (and (node-reg-p suggested)
3121                         (nx2-acode-call-p form))     ;probably ...
3122                (arm2-one-targeted-reg-form seg form  arm::arg_z)
3123                (if targeted
3124                  (arm2-one-targeted-reg-form seg form suggested)
3125                  (arm2-one-untargeted-reg-form seg form suggested)))))
3126    (arm2-push-register seg reg)))
3127
3128(defun arm2-one-lreg-form (seg form lreg)
3129  (let ((is-float (= (hard-regspec-class lreg) hard-reg-class-fpr)))
3130    (if is-float
3131      (arm2-form-float seg lreg nil form)
3132      (arm2-form seg lreg nil form))
3133    lreg))
3134
3135(defun arm2-one-targeted-reg-form (seg form reg)
3136  (arm2-one-lreg-form seg form reg))
3137
3138(defun arm2-one-untargeted-lreg-form (seg form reg)
3139  (arm2-one-lreg-form seg form (if (typep reg 'lreg) reg (make-unwired-lreg reg))))
3140
3141(defun same-arm-reg-p (x y)
3142  (and (eq (hard-regspec-value x) (hard-regspec-value y))
3143       (let* ((class (hard-regspec-class x)))
3144         (and (eq class (hard-regspec-class y))
3145              (or (not (eql class hard-reg-class-fpr))
3146                  (eq (%get-regspec-mode x)
3147                      (%get-regspec-mode y)))))))
3148
3149;;; If REG is a node reg, add it to the bitmask.
3150(defun arm2-restrict-node-target (reg mask)
3151  (if (node-reg-p reg)
3152    (logior mask (ash 1 (hard-regspec-value reg)))
3153    mask))
3154
3155;;; If suggested reg is a node reg that contains a stack location,
3156;;; try to use some other node temp.
3157(defun arm2-try-non-conflicting-reg (suggested reserved)
3158  (let* ((mask *arm2-gpr-locations-valid-mask*))
3159    (or (when (and (node-reg-p suggested)
3160                   (logbitp (hard-regspec-value suggested) mask))
3161          (setq mask (logior mask reserved))
3162          (%available-node-temp (logand *available-backend-node-temps*
3163                                        (lognot mask))))
3164        suggested)))
3165
3166(defun arm2-push-register (seg areg)
3167  (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr))
3168         (fpr-mode-name (if a-float (fpr-mode-value-name (get-regspec-mode areg))))
3169         (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node)))
3170         (nested (> *arm2-undo-count* 0))
3171         vinsn)
3172    (with-arm-local-vinsn-macros (seg)
3173      (if a-node
3174        (setq vinsn (arm2-vpush-register seg areg))
3175        (let* ((offset *arm2-nfp-depth*))
3176          (setq vinsn
3177                (if a-float
3178                  (case fpr-mode-name
3179                    ((:double-float :omplex-single-float)
3180                     (if nested
3181                       (! nfp-store-double-float-nested areg offset)
3182                       (! nfp-store-double-float areg  offset)))
3183                    (:complex-double-float
3184                     (incf offset 8)
3185                     (if nested
3186                       (! nfp-store-complex-double-float-nested areg offset)
3187                       (! nfp-store-complex-double-float areg  offset)))
3188                    (:single-float
3189                     (if nested
3190                       (! nfp-store-single-float-nested areg offset)
3191                       (! nfp-store-single-float areg offset))))
3192                  (if nested
3193                    (! nfp-store-unboxed-word-nested areg offset)
3194                    (! nfp-store-unboxed-word areg offset))))
3195          (push vinsn *arm2-all-nfp-pushes*)
3196          (incf offset 8)
3197          (setq *arm2-nfp-depth* offset)))
3198      vinsn)))
3199             
3200
3201(defun arm2-one-untargeted-reg-form (seg form suggested &optional (reserved 0))
3202  (or (arm2-reg-for-form form suggested)
3203      (if (and (acode-p form)
3204               (eq (acode-operator form) (%nx1-operator %current-tcr)))
3205        arm::rcontext
3206        (if (node-reg-p suggested)
3207          (arm2-one-untargeted-lreg-form seg form (arm2-try-non-conflicting-reg suggested reserved))
3208          (arm2-one-untargeted-lreg-form seg form suggested)))))
3209
3210(defun arm2-pop-register (seg areg)
3211  (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr))
3212         (fpr-mode-name (if a-float (fpr-mode-value-name (get-regspec-mode areg))))
3213         (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node)))
3214         (nested (> *arm2-undo-count* 0))
3215         vinsn)
3216    (with-arm-local-vinsn-macros (seg)
3217      (if a-node
3218        (setq vinsn (arm2-vpop-register seg areg))
3219        (let* ((offset (- *arm2-nfp-depth* 8)))
3220          (setq vinsn
3221                (if a-float
3222                  (case fpr-mode-name
3223                    ((:double-float :complex-single-float)
3224                     (if nested
3225                       (! nfp-load-double-float-nested areg offset)
3226                       (! nfp-load-double-float areg  offset)))
3227                    (:complex-double-float
3228                     (decf offset 8)
3229                     (if nested
3230                       (! nfp-load-complex-double-float-nested areg offset)
3231                       (! nfp-load-complex-double-float areg  offset)))
3232                    (:single-float
3233                     (if nested
3234                       (! nfp-load-single-float-nested areg offset)
3235                       (! nfp-load-single-float areg  offset))))
3236                  (if nested
3237                    (! nfp-load-unboxed-word-nested areg offset)
3238                    (! nfp-load-unboxed-word areg offset))))
3239          (setq *arm2-nfp-depth* offset)))
3240      vinsn)))
3241
3242(defun arm2-acc-reg-for (reg)
3243  (with-arm-local-vinsn-macros (seg)
3244    (if (and (eql (hard-regspec-class reg) hard-reg-class-gpr)
3245             (eql (get-regspec-mode reg) hard-reg-class-gpr-mode-node))
3246      ($ arm::arg_z)
3247      reg)))
3248
3249(defun arm2-copy-fpr (seg dest src)
3250  ;; src and dest are distinct FPRs with the same mode.
3251  (with-arm-local-vinsn-macros (seg)
3252    (case (fpr-mode-value-name (get-regspec-mode src))
3253      (:single-float (! single-to-single dest src))
3254      (:double-float (! double-to-double dest src))
3255      (:complex-single-float (! complex-single-float-to-complex-single-float
3256                                dest src))
3257      (:complex-double-float (! complex-double-float-to-complex-dooble-float
3258                                dest src)))))
3259
3260;;; The compiler often generates superfluous pushes & pops.  Try to
3261;;; eliminate them.
3262;;; It's easier to elide pushes and pops to the SP.
3263(defun arm2-elide-pushes (seg push-vinsn pop-vinsn)
3264  (with-arm-local-vinsn-macros (seg)
3265    (let* ((operands (vinsn-variable-parts push-vinsn))
3266           (pushed-reg (svref operands  0))
3267           (popped-reg (svref (vinsn-variable-parts pop-vinsn) 0))
3268           (same-reg (eq (hard-regspec-value pushed-reg)
3269                         (hard-regspec-value popped-reg)))
3270           (nfp-p (vinsn-attribute-p push-vinsn :nfp)))
3271      (when nfp-p               ; vsp case is harder.
3272        (let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p
3273                                   push-vinsn pop-vinsn pushed-reg))
3274               (popped-reg-is-set (if same-reg
3275                                    pushed-reg-is-set
3276                                    (vinsn-sequence-sets-reg-p
3277                                     push-vinsn pop-vinsn popped-reg)))
3278               (offset (svref operands 1))
3279               (nested ())
3280               (conflicts ())
3281               (win nil))
3282          (declare (fixnum offset))
3283          (do* ((element (dll-node-succ push-vinsn) (dll-node-succ element)))
3284               ((eq element pop-vinsn))
3285            (when (typep element 'vinsn)
3286              (when (vinsn-attribute-p element :nfp)
3287                (let* ((element-offset (svref (vinsn-variable-parts element) 1)))
3288                  (declare (fixnum element-offset))
3289                  (if (= element-offset offset)
3290                    (push element conflicts)
3291                    (if (> element-offset offset)
3292                      (push element nested)))))))
3293          (cond
3294            (conflicts nil)
3295            ((not (and pushed-reg-is-set popped-reg-is-set))
3296             (unless same-reg
3297               (let* ((copy (if (eq (hard-regspec-class pushed-reg)
3298                                    hard-reg-class-fpr)
3299                              (arm2-copy-fpr seg popped-reg pushed-reg)
3300                              (! copy-gpr popped-reg pushed-reg))))
3301                 (remove-dll-node copy)
3302                 (if pushed-reg-is-set
3303                   (insert-dll-node-after copy push-vinsn)
3304                   (insert-dll-node-before copy pop-vinsn))))
3305             (setq win t))
3306            ((eql (hard-regspec-class pushed-reg) hard-reg-class-fpr)
3307             (let* ((mode (get-regspec-mode pushed-reg))
3308                    (mode-name (fpr-mode-value-name mode)))
3309               ;; If we're pushing a float register that gets
3310               ;; set by the intervening vinsns, try to copy it to and
3311               ;; from a free FPR instead.
3312               (multiple-value-bind (used-gprs used-fprs)
3313                   (regs-set-in-vinsn-sequence push-vinsn pop-vinsn)
3314                 (declare (ignore used-gprs))
3315                 ;; We have 14 volatile single-floats or 7
3316                 ;; volatile double-floats
3317                 (let* ((nfprs (case mode-name
3318                                 ((:double-float :complex-single-float) 7)
3319                                 (:complex-double-float 3)
3320                                 (:single-float 14)))
3321                        (free-fpr
3322                         (dotimes (r nfprs nil)
3323                           (unless (logtest (target-fpr-mask
3324                                             r mode)
3325                                            used-fprs)
3326                             (return r)))))
3327                   (when free-fpr
3328                     (let* ((reg (make-wired-lreg free-fpr :class hard-reg-class-fpr :mode mode))
3329                            (save (arm2-copy-fpr seg reg pushed-reg))
3330                                  (restore (arm2-copy-fpr seg popped-reg reg)))
3331                       (remove-dll-node save)
3332                       (insert-dll-node-after save push-vinsn)
3333                       (remove-dll-node restore)
3334                       (insert-dll-node-before restore pop-vinsn)
3335                       (setq win t))))))))
3336          (when win
3337            (setq *arm2-all-nfp-pushes*
3338                  (delete push-vinsn *arm2-all-nfp-pushes*))
3339            (let* ((pair (assq push-vinsn *arm2-nfp-vars*)))
3340              (when pair
3341                (setf (car pair) nil)))
3342            (when nested
3343              (let* ((size (if (vinsn-attribute-p push-vinsn :uses-frame-pointer)
3344                             16
3345                             8)))
3346                (declare (fixnum size))
3347                (dolist (inner nested)
3348                  (let* ((inner-operands (vinsn-variable-parts inner)))
3349                    (setf (svref inner-operands 1)
3350                          (the fixnum
3351                            (- (the fixnum (svref inner-operands 1))
3352                               size))))
3353                  (let* ((var (cdr (assq inner *arm2-nfp-vars*))))
3354                    (when var (setf (var-ea var)
3355                                    (- (var-ea var) size)))))))
3356            (elide-vinsn push-vinsn)
3357            (elide-vinsn pop-vinsn)
3358            t) ))
3359      (when (and (vinsn-attribute-p push-vinsn :vsp))
3360        (unless (or
3361                 (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :vsp :push)
3362                 (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :vsp :pop)
3363                 (let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p
3364                                            push-vinsn pop-vinsn pushed-reg))
3365                        (popped-reg-is-set (if same-reg
3366                                             pushed-reg-is-set
3367                                             (vinsn-sequence-sets-reg-p
3368                                              push-vinsn pop-vinsn popped-reg)))
3369                        (popped-reg-is-reffed (unless same-reg
3370                                                (vinsn-sequence-refs-reg-p
3371                                                 push-vinsn pop-vinsn popped-reg))))
3372                   (cond ((and (not (and pushed-reg-is-set popped-reg-is-set))
3373                               (or (null popped-reg-is-reffed)
3374                                   (null pushed-reg-is-set)
3375                                   ;; If the popped register is
3376                                   ;; referenced and the pushed
3377                                   ;; register is set, we want to be
3378                                   ;; sure that the last reference
3379                                   ;; happens before the first
3380                                   ;; assignent.  We can't be sure
3381                                   ;; that either of these things
3382                                   ;; actually happened or happen
3383                                   ;; unconditionally, and can't
3384                                   ;; be sure of the order in which
3385                                   ;; they might happen if the sequence
3386                                   ;; contains jumps or branches.
3387                                   (vinsn-in-sequence-p pushed-reg-is-set popped-reg-is-reffed pop-vinsn)
3388                                   (not (vinsn-sequence-has-some-attribute-p push-vinsn pop-vinsn :branch :jump))))
3389                          ;; We don't try this if anything's pushed on
3390                          ;; or popped from the vstack in the
3391                          ;; sequence, but there can be references to
3392                          ;; other things that were pushed earlier.
3393                          ;; Those references use the vstack depth at
3394                          ;; the time of the reference and the
3395                          ;; canonical frame offset to address
3396                          ;; relative to the vsp.  If we elide the
3397                          ;; push, the vstack depth will be 4 bytes
3398                          ;; less than when the reference was
3399                          ;; generated.  Fix that up ...  There was
3400                          ;; (once) a notion of modeling the vstack as
3401                          ;; a list of "lcells"; lcells had a width
3402                          ;; attribute that was usually the native
3403                          ;; word size.  Eliding a push involved
3404                          ;; setting the width of the lcell
3405                          ;; representing the pushed word to 0.
3406                          ;; That whole idea was never fully implemented,
3407                          ;; though we generally try to maintain the model.
3408                          ;; If it ever is implemented, we need to dtrt
3409                          ;; here.
3410                          (do* ((element (dll-node-succ push-vinsn) (dll-node-succ element)))
3411                               ((eq element pop-vinsn))
3412                            (when (typep element 'vinsn)
3413                              (let* ((template (vinsn-template element))
3414                                     (opidx (case (vinsn-template-name template)
3415                                              (vframe-store 2)
3416                                              (vframe-load 2))))
3417                                (when opidx
3418                                  (let* ((operands (vinsn-variable-parts element)))
3419                                    (declare (simple-vector operands))
3420                                    (setf (svref operands opidx)
3421                                          (the fixnum
3422                                            (- (the fixnum (svref operands opidx))
3423                                               arm::node-size))))))))
3424                          (unless same-reg
3425                            (let* ((copy (! copy-gpr popped-reg pushed-reg)))
3426                              (remove-dll-node copy)
3427                              (if pushed-reg-is-set
3428                                  (insert-dll-node-after copy push-vinsn)
3429                                  (insert-dll-node-before copy pop-vinsn))))
3430                          (elide-vinsn push-vinsn)
3431                          (elide-vinsn pop-vinsn)
3432                          t)
3433                   (t                   ; maybe allocate a node temp
3434                    nil)))))))))
3435               
3436       
3437;;; we never leave the first form pushed (the 68K compiler had some subprims that
3438;;; would vpop the first argument out of line.)
3439(defun arm2-two-targeted-reg-forms (seg aform areg bform breg)
3440  (let* ((*arm2-nfp-depth* *arm2-nfp-depth*)
3441         (avar (arm2-lexical-reference-p aform))
3442         (atriv (and (arm2-trivial-p bform) (nx2-node-gpr-p breg)))
3443         (aconst (and (not atriv) (or (arm-side-effect-free-form-p aform)
3444                                      (if avar (nx2-var-not-set-by-form-p avar bform)))))
3445         (apushed))
3446    (progn
3447      (unless aconst
3448        (if atriv
3449          (arm2-one-targeted-reg-form seg aform areg)
3450          (setq apushed (arm2-push-reg-for-form seg aform areg t))))
3451      (arm2-one-targeted-reg-form seg bform breg)
3452      (if aconst
3453        (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)
3454               (*available-backend-node-temps* *available-backend-node-temps*)
3455               (*available-backend-fp-temps* *available-backend-fp-temps*)
3456               (bclass (hard-regspec-class breg))
3457               (bregval (hard-regspec-value breg)))
3458          (if (eq bclass hard-reg-class-fpr)
3459            (use-fp-reg breg)
3460            (if (eq bclass hard-reg-class-gpr)
3461              (if (eq (get-regspec-mode breg) hard-reg-class-gpr-mode-node)
3462                (use-node-temp bregval)
3463                (use-imm-temp bregval))))
3464          (arm2-one-targeted-reg-form seg aform areg))
3465        (if apushed
3466          (arm2-elide-pushes seg apushed (arm2-pop-register seg areg)))))
3467    (values areg breg)))
3468
3469
3470(defun arm2-two-untargeted-reg-forms (seg aform areg bform breg)
3471  (let* ((*arm2-nfp-depth* *arm2-nfp-depth*)
3472         (aalready (arm2-reg-for-form aform areg))
3473         (balready (arm2-reg-for-form bform breg)))
3474    (if (and aalready balready)
3475      (values aalready balready)
3476      (with-arm-local-vinsn-macros (seg)
3477        (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)
3478               (avar (arm2-lexical-reference-p aform))
3479               (adest nil)
3480               (bdest nil)
3481               (atriv (and (arm2-trivial-p bform) (nx2-node-gpr-p breg)))
3482               (aconst (and (not atriv) (or (arm-side-effect-free-form-p aform)
3483                                            (if avar (nx2-var-not-set-by-form-p avar bform)))))
3484               (apushed nil)
3485               (restricted 0))
3486          (progn
3487            (unless aconst
3488              (if atriv
3489                (progn
3490                  (setq adest (arm2-one-untargeted-reg-form seg aform areg)
3491                        restricted (arm2-restrict-node-target adest 0))
3492                  (when (imm-reg-p adest)
3493                    (use-imm-temp (%hard-regspec-value adest)))
3494                  (when (same-arm-reg-p adest breg)
3495                    (setq breg areg)))
3496                (setq apushed (arm2-push-reg-for-form seg aform areg))))
3497            (setq bdest (arm2-one-untargeted-reg-form seg bform breg restricted)
3498                  restricted (arm2-restrict-node-target bdest restricted))
3499            (unless adest
3500              (if (same-arm-reg-p areg bdest)
3501                (setq areg breg)))
3502            (if aconst
3503              (progn
3504                (if (imm-reg-p bdest)
3505                  (use-imm-temp (%hard-regspec-value bdest)))
3506                (setq adest (arm2-one-untargeted-reg-form seg aform areg restricted)))
3507              (if apushed
3508                (arm2-elide-pushes seg apushed (arm2-pop-register seg (setq adest areg))))))
3509          (values adest bdest))))))
3510
3511
3512(defun arm2-four-targeted-reg-forms (seg aform areg bform breg cform creg dform dreg)
3513  (let* ((*arm2-nfp-depth* *arm2-nfp-depth*)
3514         (bnode (nx2-node-gpr-p breg))
3515         (cnode (nx2-node-gpr-p creg))
3516         (dnode (nx2-node-gpr-p dreg))
3517         (atriv (or (null aform) 
3518                    (and (arm2-trivial-p bform)
3519                         (arm2-trivial-p cform)
3520                         (arm2-trivial-p dform)
3521                         bnode
3522                         cnode
3523                         dnode)))
3524         (btriv (or (null bform)
3525                    (and (arm2-trivial-p cform)
3526                         (arm2-trivial-p dform)
3527                         cnode
3528                         dnode)))
3529         (ctriv (or (null cform)
3530                    (and (arm2-trivial-p dform) dnode)))
3531         
3532         (aconst (and (not atriv) 
3533                      (or (arm-side-effect-free-form-p aform)
3534                          (let ((avar (arm2-lexical-reference-p aform)))
3535                            (and avar 
3536                                 (nx2-var-not-set-by-form-p avar bform)
3537                                 (nx2-var-not-set-by-form-p avar cform)
3538                                 (nx2-var-not-set-by-form-p avar dform))))))
3539         (bconst (and (not btriv)
3540                      (or (arm-side-effect-free-form-p bform)
3541                          (let ((bvar (arm2-lexical-reference-p bform)))
3542                            (and bvar
3543                                 (nx2-var-not-set-by-form-p bvar cform)
3544                                 (nx2-var-not-set-by-form-p bvar dform))))))
3545         (cconst (and (not ctriv)
3546                      (or (arm-side-effect-free-form-p cform)
3547                          (let ((cvar (arm2-lexical-reference-p cform)))
3548                            (and cvar
3549                                 (nx2-var-not-set-by-form-p cvar dform))))))
3550         (apushed nil)
3551         (bpushed nil)
3552         (cpushed nil))
3553    (if (and aform (not aconst))
3554      (if atriv
3555        (arm2-one-targeted-reg-form seg aform areg)
3556        (setq apushed (arm2-push-reg-for-form seg aform areg t))))
3557    (if (and bform (not bconst))
3558      (if btriv
3559        (arm2-one-targeted-reg-form seg bform breg)
3560        (setq bpushed (arm2-push-reg-for-form seg bform breg t))))
3561    (if (and cform (not cconst))
3562      (if ctriv
3563        (arm2-one-targeted-reg-form seg cform creg)
3564        (setq cpushed (arm2-push-reg-for-form seg cform creg t))))
3565    (arm2-one-targeted-reg-form seg dform dreg)
3566    (unless ctriv
3567      (if cconst
3568        (arm2-one-targeted-reg-form seg cform creg)
3569        (arm2-elide-pushes seg cpushed (arm2-pop-register seg creg))))
3570    (unless btriv 
3571      (if bconst
3572        (arm2-one-targeted-reg-form seg bform breg)
3573        (arm2-elide-pushes seg bpushed (arm2-pop-register seg breg))))
3574    (unless atriv
3575      (if aconst
3576        (arm2-one-targeted-reg-form seg aform areg)
3577        (arm2-elide-pushes seg apushed (arm2-pop-register seg areg))))
3578    (values areg breg creg dreg)))
3579
3580(defun arm2-three-targeted-reg-forms (seg aform areg bform breg cform creg)
3581  (let* ((*arm2-nfp-depth* *arm2-nfp-depth*)
3582         (bnode (nx2-node-gpr-p breg))
3583         (cnode (nx2-node-gpr-p creg))
3584         (atriv (or (null aform) 
3585                    (and (arm2-trivial-p bform)
3586                         (arm2-trivial-p cform)
3587                         bnode
3588                         cnode)))
3589         (btriv (or (null bform)
3590                    (and (arm2-trivial-p cform)
3591                         cnode)))
3592         (aconst (and (not atriv) 
3593                      (or (arm-side-effect-free-form-p aform)
3594                          (let ((avar (arm2-lexical-reference-p aform)))
3595                            (and avar 
3596                                 (nx2-var-not-set-by-form-p avar bform)
3597                                 (nx2-var-not-set-by-form-p avar cform))))))
3598         (bconst (and (not btriv)
3599                      (or
3600                       (arm-side-effect-free-form-p bform)
3601                       (let ((bvar (arm2-lexical-reference-p bform)))
3602                         (and bvar (nx2-var-not-set-by-form-p bvar cform))))))
3603         (apushed nil)
3604         (bpushed nil))
3605    (if (and aform (not aconst))
3606      (if atriv
3607        (arm2-one-targeted-reg-form seg aform areg)
3608        (setq apushed (arm2-push-reg-for-form seg aform areg t))))
3609    (if (and bform (not bconst))
3610      (if btriv
3611        (arm2-one-targeted-reg-form seg bform breg)
3612        (setq bpushed (arm2-push-reg-for-form seg bform breg t))))
3613    (arm2-one-targeted-reg-form seg cform creg)
3614    (unless btriv 
3615      (if bconst
3616        (arm2-one-targeted-reg-form seg bform breg)
3617        (arm2-elide-pushes seg bpushed (arm2-pop-register seg breg))))
3618    (unless atriv
3619      (if aconst
3620        (arm2-one-targeted-reg-form seg aform areg)
3621        (arm2-elide-pushes seg apushed (arm2-pop-register seg areg))))
3622    (values areg breg creg)))
3623
3624(defun arm2-three-untargeted-reg-forms (seg aform areg bform breg cform creg)
3625  (with-arm-local-vinsn-macros (seg)
3626    (let* ((*arm2-nfp-depth* *arm2-nfp-depth*)
3627           (bnode (nx2-node-gpr-p breg))
3628           (cnode (nx2-node-gpr-p creg))
3629           (atriv (or (null aform) 
3630                      (and (arm2-trivial-p bform)
3631                           (arm2-trivial-p cform)
3632                           bnode
3633                           cnode)))
3634           (btriv (or (null bform)
3635                      (and (arm2-trivial-p cform)
3636                           cnode)))
3637           (aconst (and (not atriv) 
3638                        (or (arm-side-effect-free-form-p aform)
3639                            (let ((avar (arm2-lexical-reference-p aform)))
3640                              (and avar 
3641                                   (nx2-var-not-set-by-form-p avar bform)
3642                                   (nx2-var-not-set-by-form-p avar cform))))))
3643           (bconst (and (not btriv)
3644                        (or
3645                         (arm-side-effect-free-form-p bform)
3646                         (let ((bvar (arm2-lexical-reference-p bform)))
3647                           (and bvar (nx2-var-not-set-by-form-p bvar cform))))))
3648           (adest nil)
3649           (bdest nil)
3650           (cdest nil)
3651           (apushed nil)
3652           (bpushed nil)
3653           (restricted 0))
3654      (when (and aform (not aconst))
3655        (if atriv
3656          (progn
3657            (setq adest (arm2-one-untargeted-reg-form seg aform ($ areg))
3658                  restricted (arm2-restrict-node-target adest 0))
3659            (when (same-arm-reg-p adest breg)
3660              (setq breg areg))
3661            (when (same-arm-reg-p adest creg)
3662              (setq creg areg)))
3663          (setq apushed (arm2-push-reg-for-form seg aform areg ))))
3664      (when (and bform (not bconst))
3665        (if btriv
3666          (progn
3667            (setq bdest (arm2-one-untargeted-reg-form seg bform ($ breg) restricted)
3668                  restricted (arm2-restrict-node-target bdest restricted))
3669            (when (same-arm-reg-p bdest creg)
3670              (setq creg breg))
3671            (when (same-arm-reg-p bdest areg)
3672              (setq areg breg)))
3673          (setq bpushed (arm2-push-reg-for-form seg bform breg))))
3674      (setq cdest (arm2-one-untargeted-reg-form seg cform creg restricted)
3675            restricted (arm2-restrict-node-target cdest restricted))
3676      (when (same-arm-reg-p cdest areg)
3677        (setq areg creg))
3678      (when (same-arm-reg-p cdest breg)
3679        (setq breg creg))
3680      (unless btriv 
3681        (if bconst
3682          (setq bdest (arm2-one-untargeted-reg-form seg bform breg restricted))
3683          (arm2-elide-pushes seg bpushed (arm2-pop-register seg (setq bdest breg))))
3684        (setq restricted (arm2-restrict-node-target bdest restricted))
3685        (when (same-arm-reg-p bdest areg)
3686          (setq areg breg)))
3687      (unless atriv
3688        (if aconst
3689          (setq adest (arm2-one-untargeted-reg-form seg aform areg restricted))
3690          (arm2-elide-pushes seg apushed (arm2-pop-register seg (setq adest areg)))))
3691      (values adest bdest cdest))))
3692
3693
3694(defun arm2-four-untargeted-reg-forms (seg aform areg bform breg cform creg dform dreg)
3695  (let* ((*arm2-nfp-depth* *arm2-nfp-depth*)
3696         (bnode (nx2-node-gpr-p breg))
3697         (cnode (nx2-node-gpr-p creg))
3698         (dnode (nx2-node-gpr-p dreg))
3699         (atriv (or (null aform) 
3700                    (and (arm2-trivial-p bform)
3701                         (arm2-trivial-p cform)
3702                         (arm2-trivial-p dform)
3703                         bnode
3704                         cnode
3705                         dnode)))
3706         (btriv (or (null bform)
3707                    (and (arm2-trivial-p cform)
3708                         (arm2-trivial-p dform)
3709                         cnode
3710                         dnode)))
3711         (ctriv (or (null cform)
3712                    (and (arm2-trivial-p dform) dnode)))
3713         (aconst (and (not atriv) 
3714                      (or (arm-side-effect-free-form-p aform)
3715                          (let ((avar (arm2-lexical-reference-p aform)))
3716                            (and avar 
3717                                 (nx2-var-not-set-by-form-p avar bform)
3718                                 (nx2-var-not-set-by-form-p avar cform)
3719                                 (nx2-var-not-set-by-form-p avar dform))))))
3720         (bconst (and (not btriv)
3721                      (or
3722                       (arm-side-effect-free-form-p bform)
3723                       (let ((bvar (arm2-lexical-reference-p bform)))
3724                         (and bvar
3725                              (nx2-var-not-set-by-form-p bvar cform)
3726                              (nx2-var-not-set-by-form-p bvar dform))))))
3727         (cconst (and (not ctriv)
3728                      (or
3729                       (arm-side-effect-free-form-p cform)
3730                       (let ((cvar (arm2-lexical-reference-p cform)))
3731                         (and cvar
3732                              (nx2-var-not-set-by-form-p cvar dform))))))
3733         (adest nil)
3734         (bdest nil)
3735         (cdest nil)
3736         (ddest nil)
3737         (apushed nil)
3738         (bpushed nil)
3739         (cpushed nil)
3740         (restricted 0))
3741    (if (and aform (not aconst))
3742      (if atriv
3743        (progn
3744          (setq adest (arm2-one-untargeted-reg-form seg aform areg)
3745                restricted (arm2-restrict-node-target adest restricted))
3746          (when (same-arm-reg-p adest breg)
3747            (setq breg areg))
3748          (when (same-arm-reg-p adest creg)
3749            (setq creg areg))
3750          (when (same-arm-reg-p adest dreg)
3751            (setq dreg areg)))
3752        (setq apushed (arm2-push-reg-for-form seg aform areg))))
3753    (if (and bform (not bconst))
3754      (if btriv
3755        (progn
3756          (setq bdest (arm2-one-untargeted-reg-form seg bform breg restricted)
3757                restricted (arm2-restrict-node-target bdest restricted))
3758          (unless adest
3759            (when (same-arm-reg-p areg bdest)
3760              (setq areg breg)))
3761          (when (same-arm-reg-p bdest creg)
3762            (setq creg breg))
3763          (when (same-arm-reg-p bdest dreg)
3764            (setq dreg breg)))
3765        (setq bpushed (arm2-push-reg-for-form seg bform breg))))
3766    (if (and cform (not cconst))
3767      (if ctriv
3768        (progn
3769          (setq cdest (arm2-one-untargeted-reg-form seg cform creg restricted)
3770                restricted (arm2-restrict-node-target cdest restricted))
3771          (unless adest
3772            (when (same-arm-reg-p areg cdest)
3773              (setq areg creg)))
3774          (unless bdest
3775            (when (same-arm-reg-p breg cdest)
3776              (setq breg creg)))         
3777          (when (same-arm-reg-p cdest dreg)
3778            (setq dreg creg)))
3779        (setq cpushed (arm2-push-reg-for-form seg cform creg))))
3780    (setq ddest (arm2-one-untargeted-reg-form seg dform dreg restricted)
3781          restricted (arm2-restrict-node-target ddest restricted))
3782    (unless adest
3783      (when (same-arm-reg-p ddest areg)
3784        (setq areg dreg)))
3785    (unless bdest
3786      (when (same-arm-reg-p ddest breg)
3787        (setq breg dreg)))
3788    (unless cdest
3789      (when (same-arm-reg-p ddest creg)
3790        (setq creg dreg)))
3791    (unless ctriv 
3792      (if cconst
3793        (setq cdest (arm2-one-untargeted-reg-form seg cform creg restricted))
3794        (arm2-elide-pushes seg cpushed (arm2-pop-register seg (setq cdest creg))))
3795      (setq restricted (arm2-restrict-node-target cdest restricted))
3796      (unless adest
3797        (when (same-arm-reg-p cdest areg)
3798          (setq areg creg)))
3799      (unless bdest
3800        (when (same-arm-reg-p ddest breg)
3801          (setq breg creg))))
3802    (unless btriv 
3803      (if bconst
3804        (setq bdest (arm2-one-untargeted-reg-form seg bform breg restricted))
3805        (arm2-elide-pushes seg bpushed (arm2-pop-register seg (setq bdest breg))))
3806      (setq restricted (arm2-restrict-node-target bdest restricted))
3807      (unless adest
3808        (when (same-arm-reg-p bdest areg)
3809          (setq areg breg))))
3810    (unless atriv
3811      (if aconst
3812        (setq adest (arm2-one-untargeted-reg-form seg aform areg restricted))
3813        (arm2-elide-pushes seg apushed (arm2-pop-register seg (setq adest areg)))))
3814    (values adest bdest cdest ddest)))
3815
3816(defun arm2-lri (seg reg value)
3817  (with-arm-local-vinsn-macros (seg)
3818    (if (>= value 0)
3819      (! lri reg value)
3820      (! lri reg (logand value #xffffffff)))))
3821
3822
3823(defun arm2-multiple-value-body (seg form)
3824  (let* ((lab (backend-get-next-label))
3825         (*arm2-vstack* *arm2-vstack*)
3826         (old-stack (arm2-encode-stack)))
3827    (with-arm-local-vinsn-macros (seg)
3828      (arm2-open-undo $undomvexpect)
3829      (arm2-undo-body seg nil (logior $backend-mvpass-mask lab) form old-stack)
3830      (@ lab))))
3831
3832(defun arm2-afunc-lfun-ref (afunc)
3833  (or
3834   (afunc-lfun afunc)
3835   (progn (pushnew afunc (afunc-fwd-refs *arm2-cur-afunc*) :test #'eq)
3836          afunc)))
3837
3838(defun arm2-augment-arglist (afunc arglist &optional (maxregs $numarmargregs))
3839  (let ((inherited-args (afunc-inherited-vars afunc)))
3840    (when inherited-args
3841      (let* ((current-afunc *arm2-cur-afunc*)
3842             (stkargs (car arglist))
3843             (regargs (cadr arglist))
3844             (inhforms nil)
3845             (numregs (length regargs))
3846             (own-inhvars (afunc-inherited-vars current-afunc)))
3847        (dolist (var inherited-args)
3848          (let* ((root-var (nx-root-var var))
3849                 (other-guy 
3850                  (dolist (v own-inhvars #|(compiler-bug "other guy not found")|# root-var)
3851                    (when (eq root-var (nx-root-var v)) (return v)))))
3852            (push (make-acode (%nx1-operator inherited-arg) other-guy) inhforms)))
3853        (dolist (form inhforms)
3854          (if (%i< numregs maxregs)
3855            (progn
3856              (setq regargs (nconc regargs (list form)))
3857              (setq numregs (%i+ numregs 1)))
3858            (push form stkargs)))
3859        (%rplaca (%cdr arglist) regargs) ; might have started out NIL.
3860        (%rplaca arglist stkargs)))) 
3861  arglist)
3862
3863(defun arm2-constant-for-compare-p (form &optional unboxed)
3864  (setq form (acode-unwrapped-form form))
3865  (when (acode-p form)
3866    (let* ((op (acode-operator form)))
3867      (if (eql op (%nx1-operator fixnum))
3868        (let* ((val (if unboxed
3869                      (car (acode-operands form))
3870                      (ash (car (acode-operands form)) arm::fixnumshift))))
3871          (if (or (arm::encode-arm-immediate val)
3872                  (arm::encode-arm-immediate (- val)))
3873            (logand val #xffffffff)))
3874        (if (eql op (%nx1-operator %unbound-marker))
3875          arm::unbound-marker
3876          (if (eql op (%nx1-operator %slot-unbound-marker))
3877            arm::slot-unbound-marker))))))
3878
3879(defun arm2-acode-operator-supports-u8 (form)
3880  (setq form (acode-unwrapped-form-value form))
3881  (when (acode-p form)
3882    (let* ((operator (acode-operator form)))
3883      (if (member operator *arm2-operator-supports-u8-target*)
3884        (values operator (car (acode-operands form)))))))
3885
3886(defun arm2-compare-u8 (seg vreg xfer form u8constant cr-bit true-p u8-operator)
3887  (with-arm-local-vinsn-macros (seg vreg xfer)
3888    (with-imm-target () (u8 :u8)
3889      (with-crf-target () crf
3890        (if (and (eql u8-operator (%nx1-operator lisptag))
3891                 (eql 0 u8constant)
3892                 (eql cr-bit arm::arm-cond-eq))
3893          (let* ((formreg (arm2-one-untargeted-reg-form seg form arm::arg_z)))
3894            (! test-fixnum crf formreg))
3895          (progn
3896           (arm2-use-operator u8-operator seg u8 nil form)
3897           (! compare-immediate crf u8 u8constant))))
3898      ;; Flags set.  Branch or return a boolean value ?
3899      (regspec-crf-gpr-case 
3900       (vreg)
3901       (^ cr-bit true-p)
3902       (progn
3903         (ensuring-node-target (target vreg)
3904           (if (not true-p)
3905             (setq cr-bit (logxor 1 cr-bit)))
3906           (! cond->boolean target cr-bit))
3907         (^))))))
3908
3909;;; There are other cases involving constants that are worth exploiting.
3910(defun arm2-compare (seg vreg xfer i j cr-bit true-p)
3911  (with-arm-local-vinsn-macros (seg vreg xfer)
3912    (let* ((iu8 (let* ((i-fixnum (acode-fixnum-form-p i)))
3913                  (if (typep i-fixnum '(unsigned-byte 8))
3914                    i-fixnum)))
3915           (ju8 (let* ((j-fixnum (acode-fixnum-form-p j)))
3916                  (if (typep j-fixnum '(unsigned-byte 8))
3917                    j-fixnum)))
3918           (u8 (or iu8 ju8))
3919           (other-u8 (if iu8 j (if ju8 i)))
3920           (jconst (arm2-constant-for-compare-p j))
3921           (iconst (arm2-constant-for-compare-p i))
3922           (boolean (backend-crf-p vreg)))
3923      (multiple-value-bind (u8-operator u8-operand) (if other-u8 (arm2-acode-operator-supports-u8 other-u8))
3924        (if u8-operator
3925          (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)
3926          (if (and boolean (or iconst jconst))
3927            (let* ((reg (arm2-one-untargeted-reg-form seg (if jconst i j) arm::arg_z)))
3928              (! compare-immediate vreg reg (or jconst iconst))
3929              (unless (or jconst (eq cr-bit arm::arm-cond-eq))
3930                (setq cr-bit (arm2-cr-bit-for-reversed-comparison cr-bit)))
3931              (^ cr-bit true-p))
3932            (if (or jconst iconst)
3933              (progn
3934                (unless (or jconst (eq cr-bit arm::arm-cond-eq))
3935                  (setq cr-bit (arm2-cr-bit-for-reversed-comparison cr-bit)))                (arm2-test-reg-%izerop 
3936                  seg 
3937                  vreg 
3938                  xfer 
3939                  (arm2-one-untargeted-reg-form 
3940                   seg 
3941                   (if jconst i j) 
3942                   arm::arg_z) 
3943                  cr-bit 
3944                  true-p 
3945                  (or jconst iconst)))
3946              (multiple-value-bind (ireg jreg) (arm2-two-untargeted-reg-forms seg i arm::arg_y j arm::arg_z)
3947                (arm2-compare-registers seg vreg xfer ireg jreg cr-bit true-p)))))))))
3948
3949(defun arm2-natural-compare (seg vreg xfer i j cr-bit true-p)
3950  (with-arm-local-vinsn-macros (seg vreg xfer)
3951    (let* ((jconst (arm2-constant-for-compare-p j t))
3952           (iconst (arm2-constant-for-compare-p i t))
3953           (boolean (backend-crf-p vreg)))
3954          (if (and boolean (or iconst jconst))
3955            (let* ((reg (arm2-one-untargeted-reg-form seg (if jconst i j) ($ arm::imm0 :mode :u32))))
3956              (! compare-immediate vreg reg (or jconst iconst))
3957              (unless (or jconst (eq cr-bit arm::arm-cond-eq))
3958                (setq cr-bit (arm2-cr-bit-for-reversed-comparison cr-bit)))
3959              (^ cr-bit true-p))
3960            (if (and (eq cr-bit arm::arm-cond-eq) 
3961                     (or jconst iconst))
3962              (arm2-test-reg-%izerop 
3963               seg 
3964               vreg 
3965               xfer 
3966               (arm2-one-untargeted-reg-form 
3967                seg 
3968                (if jconst i j) 
3969                ($ arm::imm0 :mode :u32))
3970               cr-bit 
3971               true-p 
3972               (or jconst iconst))
3973              (multiple-value-bind (ireg jreg) (arm2-two-untargeted-reg-forms seg i ($ arm::imm0 :mode :u32)  j ($ arm::imm1 :mode :u32))
3974                (arm2-compare-registers seg vreg xfer ireg jreg cr-bit true-p)))))))
3975
3976
3977
3978(defun arm2-compare-registers (seg vreg xfer ireg jreg cr-bit true-p)
3979  (with-arm-local-vinsn-macros (seg vreg xfer)
3980    (if vreg
3981      (regspec-crf-gpr-case 
3982       (vreg)
3983       (progn
3984         (! compare vreg ireg jreg)
3985         (^ cr-bit true-p))
3986       (with-crf-target () crf
3987         (! compare crf ireg jreg)
3988         (ensuring-node-target (target vreg)
3989           (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))))
3990         (^)))
3991      (^))))
3992
3993(defun arm2-compare-register-to-nil (seg vreg xfer ireg cr-bit true-p)
3994  (with-arm-local-vinsn-macros (seg vreg xfer)
3995    (if vreg
3996      (regspec-crf-gpr-case 
3997       (vreg)
3998       (progn
3999         (! compare-to-nil vreg ireg)
4000         (^ cr-bit true-p))
4001       (with-crf-target () crf
4002         (! compare-to-nil crf ireg)
4003         (ensuring-node-target (target vreg)
4004           (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))))
4005         (^)))
4006      (^))))
4007
4008(defun arm2-compare-double-float-registers (seg vreg xfer ireg jreg cr-bit true-p)
4009  (with-arm-local-vinsn-macros (seg vreg xfer)
4010    (if vreg
4011      (regspec-crf-gpr-case 
4012       (vreg)
4013       (progn
4014         (! double-float-compare vreg ireg jreg)
4015         (^ cr-bit true-p))
4016       (progn
4017         (with-crf-target () flags
4018           (! double-float-compare flags ireg jreg)
4019
4020           (! cond->boolean vreg (if true-p cr-bit (logxor cr-bit 1))))
4021         (^)))
4022      (^))))
4023
4024(defun arm2-compare-single-float-registers (seg vreg xfer ireg jreg cr-bit true-p)
4025  (with-arm-local-vinsn-macros (seg vreg xfer)
4026    (if vreg
4027      (regspec-crf-gpr-case 
4028       (vreg)
4029       (progn
4030         (! single-float-compare vreg ireg jreg)
4031         (^ cr-bit true-p))
4032       (progn
4033         (with-crf-target () flags
4034           (! single-float-compare flags ireg jreg)
4035
4036           (! cond->boolean vreg (if true-p cr-bit (logxor cr-bit 1))))
4037         (^)))
4038      (^))))
4039
4040
4041
4042
4043(defun arm2-immediate-form-p (form)
4044  (if (and (acode-p form)
4045           (or (eq (acode-operator form) (%nx1-operator immediate))
4046               (eq (acode-operator form) (%nx1-operator simple-function))))
4047    t))
4048
4049(defun arm2-test-%izerop (seg vreg xfer form cr-bit true-p)
4050  (arm2-test-reg-%izerop seg vreg xfer (arm2-one-untargeted-reg-form seg form arm::arg_z) cr-bit true-p 0))
4051
4052(defun arm2-test-reg-%izerop (seg vreg xfer reg cr-bit true-p  zero)
4053  (declare (fixnum reg))
4054  (with-arm-local-vinsn-macros (seg vreg xfer)
4055    (regspec-crf-gpr-case 
4056     (vreg)
4057     (progn
4058       (if (or (arm::encode-arm-immediate zero)
4059               (arm::encode-arm-immediate (- zero)))
4060         (! compare-immediate vreg reg zero)
4061         (with-node-target (reg) other
4062           (arm2-lri seg other zero)
4063           (! compare vreg reg other)))
4064       (^ cr-bit true-p))
4065     (with-crf-target () crf
4066       (if (or (arm::encode-arm-immediate zero)
4067               (arm::encode-arm-immediate (- zero)))
4068         (! compare-immediate crf reg (logand #xffffffff zero))
4069         (with-node-target (reg) other
4070           (arm2-lri seg other zero)
4071           (! compare crf reg other)))
4072       (ensuring-node-target (target vreg)
4073         (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))))
4074       (^)))))
4075
4076(defun arm2-lexical-reference-ea (form &optional (no-closed-p t))
4077  (when (acode-p (setq form (acode-unwrapped-form-value form)))
4078    (if (eq (acode-operator form) (%nx1-operator lexical-reference))
4079      (let* ((addr (var-ea (car (acode-operands form)))))
4080        (if (typep addr 'lreg)
4081          addr
4082          (unless (and no-closed-p (addrspec-vcell-p addr ))
4083            addr))))))
4084
4085
4086(defun arm2-vpush-register (seg src)
4087  (with-arm-local-vinsn-macros (seg)
4088    (prog1
4089      (! vpush-register src)
4090      (arm2-regmap-note-store src *arm2-vstack*)
4091      (arm2-adjust-vstack *arm2-target-node-size*))))
4092
4093(defun arm2-vpush-register-arg (seg src)
4094  (arm2-vpush-register seg src))
4095
4096
4097(defun arm2-vpop-register (seg dest)
4098  (with-arm-local-vinsn-macros (seg)
4099    (prog1
4100      (! vpop-register dest)
4101      (arm2-adjust-vstack (- *arm2-target-node-size*)))))
4102
4103
4104
4105     
4106       
4107
4108 
4109     
4110     
4111(defun arm2-copy-register (seg dest src)
4112  (with-arm-local-vinsn-macros (seg)
4113    (when dest
4114      (let* ((dest-gpr (backend-ea-physical-reg dest hard-reg-class-gpr))
4115             (src-gpr (if src (backend-ea-physical-reg src hard-reg-class-gpr)))
4116             (dest-fpr (backend-ea-physical-reg dest hard-reg-class-fpr))
4117             (src-fpr (if src (backend-ea-physical-reg src hard-reg-class-fpr)))
4118             (src-mode (if src (get-regspec-mode src)))
4119             (dest-mode (get-regspec-mode dest))
4120             (dest-crf (backend-ea-physical-reg dest hard-reg-class-crf)))
4121        (if (null src)
4122          (if dest-gpr
4123            (! load-nil dest-gpr)
4124            (if dest-crf
4125              (! set-eq-bit dest-crf)))
4126          (if dest-crf
4127            ;; "Copying" a GPR to a CR field means comparing it to nil
4128            (if src-gpr
4129              (! compare-to-nil dest src)
4130              (! compare-to-nil dest arm::sp))
4131            (if (and dest-gpr src-gpr)
4132              (case dest-mode
4133                (#.hard-reg-class-gpr-mode-node ; boxed result.
4134                 (case src-mode
4135                   (#.hard-reg-class-gpr-mode-node
4136                    (unless (eql  dest-gpr src-gpr)
4137                      (! copy-gpr dest src)))
4138                   (#.hard-reg-class-gpr-mode-u32
4139                    (arm2-box-u32 seg dest src))
4140                   (#.hard-reg-class-gpr-mode-s32
4141                    (arm2-box-s32 seg dest src))
4142                   (#.hard-reg-class-gpr-mode-u16
4143                    (! u16->fixnum dest src))
4144                   (#.hard-reg-class-gpr-mode-s16
4145                    (! s16->fixnum dest src))
4146                   (#.hard-reg-class-gpr-mode-u8
4147                    (! u8->fixnum dest src))
4148                   (#.hard-reg-class-gpr-mode-s8
4149                    (! s8->fixnum dest src))
4150                   (#.hard-reg-class-gpr-mode-address
4151                    (! macptr->heap dest src))))
4152                ((#.hard-reg-class-gpr-mode-u32
4153                  #.hard-reg-class-gpr-mode-address)
4154                 (case src-mode
4155                   (#.hard-reg-class-gpr-mode-node
4156                    (let* ((src-type (get-node-regspec-type-modes src)))
4157                      (declare (fixnum src-type))
4158                      (case dest-mode
4159                        (#.hard-reg-class-gpr-mode-u32
4160                         (! unbox-u32 dest src))
4161                        (#.hard-reg-class-gpr-mode-address
4162                         (unless (or (logbitp #.hard-reg-class-gpr-mode-address src-type)
4163                                     *arm2-reckless*)
4164                           (! trap-unless-macptr src))
4165                         (! deref-macptr dest src)))))
4166                   ((#.hard-reg-class-gpr-mode-u32
4167                     #.hard-reg-class-gpr-mode-s32
4168                     #.hard-reg-class-gpr-mode-address)
4169                    (unless (eql  dest-gpr src-gpr)
4170                      (! copy-gpr dest src)))
4171                   ((#.hard-reg-class-gpr-mode-u16
4172                     #.hard-reg-class-gpr-mode-s16)
4173                    (! u16->u32 dest src))
4174                   ((#.hard-reg-class-gpr-mode-u8
4175                     #.hard-reg-class-gpr-mode-s8)
4176                    (! u8->u32 dest src))))
4177                (#.hard-reg-class-gpr-mode-s32
4178                 (case src-mode
4179                   (#.hard-reg-class-gpr-mode-node
4180                    (! unbox-s32 dest src))
4181                   ((#.hard-reg-class-gpr-mode-u32
4182                     #.hard-reg-class-gpr-mode-s32
4183                     #.hard-reg-class-gpr-mode-address)
4184                    (unless (eql  dest-gpr src-gpr)
4185                      (! copy-gpr dest src)))
4186                   (#.hard-reg-class-gpr-mode-u16
4187                    (! u16->u32 dest src))                 
4188                   (#.hard-reg-class-gpr-mode-s16
4189                    (! s16->s32 dest src))
4190                   (#.hard-reg-class-gpr-mode-u8
4191                    (! u8->u32 dest src))
4192                   (#.hard-reg-class-gpr-mode-s8
4193                    (! s8->s32 dest src))))
4194                (#.hard-reg-class-gpr-mode-u16
4195                 (case src-mode
4196                   (#.hard-reg-class-gpr-mode-node
4197                    (! unbox-u16 dest src))
4198                   ((#.hard-reg-class-gpr-mode-u8
4199                     #.hard-reg-class-gpr-mode-s8)
4200                    (! u8->u32 dest src))
4201                   (t
4202                    (unless (eql dest-gpr src-gpr)
4203                      (! copy-gpr dest src)))))
4204                (#.hard-reg-class-gpr-mode-s16
4205                 (case src-mode
4206                   (#.hard-reg-class-gpr-mode-node
4207                    (! unbox-s16 dest src))
4208                   (#.hard-reg-class-gpr-mode-s8
4209                    (! s8->s32 dest src))
4210                   (#.hard-reg-class-gpr-mode-u8
4211                    (! u8->u32 dest src))
4212                   (t
4213                    (unless (eql dest-gpr src-gpr)
4214                      (! copy-gpr dest src)))))
4215                (#.hard-reg-class-gpr-mode-u8
4216                 (case src-mode
4217                   (#.hard-reg-class-gpr-mode-node
4218                    (if *arm2-reckless*
4219                      (! %unbox-u8 dest src)
4220                      (! unbox-u8 dest src)))
4221                   (t
4222                    (unless (eql dest-gpr src-gpr)
4223                      (! copy-gpr dest src)))))
4224                (#.hard-reg-class-gpr-mode-s8
4225                 (case src-mode
4226                   (#.hard-reg-class-gpr-mode-node
4227                    (! unbox-s8 dest src))
4228                   (t
4229                    (unless (eql dest-gpr src-gpr)
4230                      (! copy-gpr dest src))))))
4231              (if src-gpr
4232                (if dest-fpr
4233                  (progn
4234                    (case src-mode
4235                      (#.hard-reg-class-gpr-mode-node
4236                       (case dest-mode
4237                         (#.hard-reg-class-fpr-mode-double
4238                          (unless (or (logbitp hard-reg-class-fpr-type-double 
4239                                               (get-node-regspec-type-modes src))
4240                                      *arm2-reckless*)
4241                            (! trap-unless-double-float src))
4242                          (! get-double dest src))
4243                         (#.hard-reg-class-fpr-mode-single
4244                          (unless *arm2-reckless*
4245                            (! trap-unless-single-float src))
4246                          (! get-single dest src))
4247                                                  (#.hard-reg-class-fpr-mode-complex-single-float
4248                          (unless *arm2-reckless*
4249                            (! trap-unless-typecode= src arm::subtag-complex-single-float))
4250                          (! get-complex-single-float dest src))
4251                         (#.hard-reg-class-fpr-mode-complex-double-float
4252                          (unless *arm2-reckless*
4253                            (! trap-unless-typecode= src arm::subtag-complex-double-float))
4254                          (! get-complex-double-float dest src)))))))
4255                (if dest-gpr
4256                  (case dest-mode
4257                    (#.hard-reg-class-gpr-mode-node
4258                     (if src-fpr
4259                       (case src-mode
4260                         (#.hard-reg-class-fpr-mode-double
4261                          (! double->heap dest src))
4262                         (#.hard-reg-class-fpr-mode-complex-double-float
4263                            (! complex-double-float->heap dest src))
4264                         (#.hard-reg-class-fpr-mode-single
4265                          (! single->node dest src))
4266                         (#.hard-reg-class-fpr-mode-complex-single-float
4267                            (! complex-single-float->node dest src))))))
4268                  (if (and src-fpr dest-fpr)
4269                    (unless (and (eql dest-fpr src-fpr)
4270                                 (eql dest-mode src-mode))
4271                      (case src-mode
4272                        (#.hard-reg-class-fpr-mode-single
4273                         (case dest-mode
4274                           (#.hard-reg-class-fpr-mode-single
4275                            (! single-to-single dest src))
4276                           (#.hard-reg-class-fpr-mode-double
4277                            (if *arm2-float-safety*
4278