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

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

When "eliding pushes", if the pushed and popped registers are disjoint
and the popped register is set in the intervening sequence but the pushed
register isn't we need to generate a COPY of the pushed reg to the popped
reg at the point of the POP.

The x86 backend got this wrong in both the FPR and GPR cases; the ARM
got this right in the GPR case but missed an FPR case.

Fixes ticket:1037 in the trunk; the bug is about a year old, but the
code in question has only been used for PROG1 in the trunk for the last
week or so.

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