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

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

ARM-specific changes, mostly.

When running lisp code (in almost all cases), keep the constant 0.0d0
in the d7 register (and therefore 0.0s0 in s14 and s15). We use d7 as
a vector header when saving non-volatile FPRs on the stack; we
actually only modify s14, so we now restore s14 after it's been used
this way. The value used in the header in lisp and kernel code is
loaded from PC-relative memory, which means that we no longer use
fmsr/fmdrr or similar instructions.

When starting a lisp thread or entering one via a callback, initialize
d7.

This all basically means that we can get 0.0[d|s]0 into an FPR (or
exploit the fact that it's already in one) a bit easier, and that's
generally a good thing. It's an ABI change, which means that the
FASL and image versions (for the ARM port only) changed; new binaries
are included in this commit.

The kernel changes to support the use of d7 are mostly pretty obvious.
In working on them, I noticed that "local labels" and "macro labels"
were in the same namespace, and we were only avoiding conflicts by
accident. For 10 years or so. (I also noticed that GAS doesn't fully
support PC-relative operands, so did that by hand.)

File size: 412.7 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                 arm::single-float-zero
1309                 (if (and (= (get-regspec-mode hint) hard-reg-class-fpr-mode-double)
1310                          (eql val 0.0d0))
1311                   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(defun arm2-lcell-to-register (seg lcell reg)
1345  (with-arm-local-vinsn-macros (seg)
1346    (! lcell-load reg lcell (arm2-vstack-mark-top))))
1347
1348(defun arm2-register-to-lcell (seg reg lcell)
1349  (with-arm-local-vinsn-macros (seg)
1350    (! lcell-store reg lcell (arm2-vstack-mark-top))))
1351
1352(defun arm2-register-to-stack (seg reg memspec)
1353  (with-arm-local-vinsn-macros (seg)
1354    (let* ((offset (memspec-frame-address-offset memspec))
1355           (vinsn (! vframe-store reg offset *arm2-vstack*)))
1356      (arm2-regmap-note-store (%hard-regspec-value reg) offset)
1357      vinsn)))
1358
1359
1360(defun arm2-ea-open (ea)
1361  (if (and ea (not (typep ea 'lreg)) (addrspec-vcell-p ea))
1362    (make-memory-spec (memspec-frame-address-offset ea))
1363    ea))
1364
1365(defun arm2-set-NARGS (seg n)
1366  (if (> n call-arguments-limit)
1367    (compiler-bug "~s exceeded." call-arguments-limit)
1368    (if (< n 256)     
1369      (with-arm-local-vinsn-macros (seg)
1370        (! set-nargs n))
1371      (arm2-lri seg arm::nargs (ash n arm::word-shift)))))
1372
1373(defun arm2-single-float-bits (the-sf)
1374  (single-float-bits the-sf))
1375
1376(defun arm2-double-float-bits (the-df)
1377  (double-float-bits the-df))
1378
1379(defun arm2-immediate (seg vreg xfer form)
1380  (with-arm-local-vinsn-macros (seg vreg xfer)
1381    (if vreg
1382      (if (and (= (hard-regspec-class vreg) hard-reg-class-fpr)
1383               (or (and (typep form 'double-float) (= (get-regspec-mode vreg) hard-reg-class-fpr-mode-double))
1384                   (and (typep form 'short-float)(= (get-regspec-mode vreg) hard-reg-class-fpr-mode-single))))
1385        (if (zerop form)
1386          (if (eql form 0.0d0)
1387            (! zero-double-float-register vreg)
1388            (! zero-single-float-register vreg))
1389          (if (typep form 'short-float)
1390            (let* ((bits (arm2-single-float-bits form)))
1391              (with-imm-temps () ((bitsreg :u32))
1392                (! lri bitsreg bits)
1393                (! load-single-float-constant vreg bitsreg)))
1394            (multiple-value-bind (high low) (arm2-double-float-bits form)
1395              (declare (integer high low))
1396              (! load-double-float-constant-from-data vreg high low))))
1397        (if (and (typep form '(unsigned-byte 32))
1398                 (= (hard-regspec-class vreg) hard-reg-class-gpr)
1399                 (= (get-regspec-mode vreg)
1400                    hard-reg-class-gpr-mode-u32))
1401          (arm2-lri seg vreg form)
1402          (ensuring-node-target (target vreg)
1403            (let* ((regno (hard-regspec-value target))
1404                   (regs (arm2-gprs-containing-constant form)))
1405              (unless (logbitp regno regs)
1406                (if (eql 0 regs)
1407                  (if (characterp form)
1408                    (! load-character-constant target (char-code form))
1409                    (arm2-store-immediate seg form target))
1410                  (let* ((r (1- (integer-length regs))))
1411                    (! copy-node-gpr target r)))
1412                (setf *arm2-gpr-constants-valid-mask*
1413                      (logior *arm2-gpr-constants-valid-mask*
1414                              (ash 1 regno))
1415                      (svref *arm2-gpr-constants* regno) form))))))
1416        (if (and (listp form) *load-time-eval-token* (eq (car form) *load-time-eval-token*))
1417          (arm2-store-immediate seg form ($ arm::temp0))))
1418    (^)))
1419
1420(defun arm2-register-constant-p (form)
1421  (and (consp form)
1422           (or (memq form *arm2-vcells*)
1423               (memq form *arm2-fcells*))
1424           (%cdr form)))
1425
1426(defun arm2-store-immediate (seg imm dest)
1427  (with-arm-local-vinsn-macros (seg)
1428    (let* ((reg (arm2-register-constant-p imm)))
1429      (if reg
1430        (arm2-copy-register seg dest reg)
1431        (let* ((idx (backend-immediate-index imm)))
1432          (if (< idx 4094)
1433            (! ref-constant dest idx)
1434            (with-imm-target () (idxreg :s32)
1435              (arm2-lri seg idxreg (+ arm::misc-data-offset (ash (1+ idx) 2)))
1436              (! ref-indexed-constant dest idxreg)))))
1437      dest)))
1438
1439
1440;;; Returns label iff form is (local-go <tag>) and can go without adjusting stack.
1441(defun arm2-go-label (form)
1442  (let ((current-stack (arm2-encode-stack)))
1443    (while (and (acode-p form) (or (eq (acode-operator form) (%nx1-operator progn))
1444                                   (eq (acode-operator form) (%nx1-operator local-tagbody))))
1445      (setq form (caadr form)))
1446    (when (acode-p form)
1447      (let ((op (acode-operator form)))
1448        (if (and (eq op (%nx1-operator local-go))
1449                 (arm2-equal-encodings-p (%caddr (%cadr form)) current-stack))
1450          (%cadr (%cadr form))
1451          (if (and (eq op (%nx1-operator local-return-from))
1452                   (nx-null (caddr form)))
1453            (let ((tagdata (car (cadr form))))
1454              (and (arm2-equal-encodings-p (cdr tagdata) current-stack)
1455                   (null (caar tagdata))
1456                   (< 0 (cdar tagdata) $backend-mvpass)
1457                   (cdar tagdata)))))))))
1458
1459(defun arm2-single-valued-form-p (form)
1460  (setq form (acode-unwrapped-form-value form))
1461  (or (nx-null form)
1462      (nx-t form)
1463      (if (acode-p form)
1464        (let ((op (acode-operator form)))
1465          (or (%ilogbitp operator-single-valued-bit op)
1466              (and (eql op (%nx1-operator values))
1467                   (let ((values (cadr form)))
1468                     (and values (null (cdr values)))))
1469              nil                       ; Learn about functions someday
1470              )))))
1471
1472
1473(defun arm2-box-s32 (seg node-dest s32-src)
1474  (with-arm-local-vinsn-macros (seg)
1475    (if *arm2-open-code-inline*
1476      (! s32->integer node-dest s32-src)
1477      (let* ((arg_z ($ arm::arg_z))
1478             (imm0 ($ arm::imm0 :mode :s32)))
1479        (arm2-copy-register seg imm0 s32-src)
1480        (! call-subprim (arm::arm-subprimitive-offset '.SPmakes32))
1481        (arm2-copy-register seg node-dest arg_z)))))
1482
1483
1484
1485(defun arm2-box-u32 (seg node-dest u32-src)
1486  (with-arm-local-vinsn-macros (seg)
1487    (if *arm2-open-code-inline*
1488      (! u32->integer node-dest u32-src)
1489      (let* ((arg_z ($ arm::arg_z))
1490             (imm0 ($ arm::imm0 :mode :u32)))
1491        (arm2-copy-register seg imm0 u32-src)
1492        (! call-subprim (arm::arm-subprimitive-offset '.SPmakeu32))
1493        (arm2-copy-register seg node-dest arg_z)))))
1494
1495
1496
1497(defun arm2-vref1 (seg vreg xfer type-keyword src unscaled-idx index-known-fixnum)
1498  (with-arm-local-vinsn-macros (seg vreg xfer)
1499    (when vreg
1500      (let* ((arch (backend-target-arch *target-backend*))
1501             (is-node (member type-keyword (arch::target-gvector-types arch)))
1502             (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch)))
1503
1504             (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
1505             (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
1506             (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
1507             (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
1508             (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector)))
1509             (vreg-class (hard-regspec-class vreg))
1510             (vreg-mode
1511              (if (or (eql vreg-class hard-reg-class-gpr)
1512                      (eql vreg-class hard-reg-class-fpr))
1513                (get-regspec-mode vreg)
1514                hard-reg-class-gpr-mode-invalid))
1515             (temp-is-vreg nil))
1516        (cond
1517          (is-node
1518           (ensuring-node-target (target vreg)
1519             (if (and index-known-fixnum (<= index-known-fixnum
1520                                             (arch::target-max-32-bit-constant-index arch)))
1521               (! misc-ref-c-node target src index-known-fixnum)
1522               (with-imm-target () (idx-reg :u64)
1523                 (if index-known-fixnum
1524                   (arm2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum *arm2-target-node-shift*)))
1525                   (! scale-node-misc-index idx-reg unscaled-idx))
1526                 (! misc-ref-node target src idx-reg)))))
1527          (is-32-bit
1528           (with-imm-target () (temp :u32)
1529             (with-fp-target () (fp-val :single-float)
1530               (if (eql vreg-class hard-reg-class-gpr)
1531                 (if
1532                   (if is-signed
1533                     (or (eql vreg-mode hard-reg-class-gpr-mode-s32)
1534                         (eql vreg-mode hard-reg-class-gpr-mode-s64))
1535                     (or (eql vreg-mode hard-reg-class-gpr-mode-u32)
1536                         (eql vreg-mode hard-reg-class-gpr-mode-u64)))
1537                   (setq temp vreg temp-is-vreg t)
1538                   (if is-signed
1539                     (set-regspec-mode temp hard-reg-class-gpr-mode-s32)))
1540                 (if (and (eql vreg-class hard-reg-class-fpr)
1541                          (eql vreg-mode hard-reg-class-fpr-mode-single))
1542                   (setf fp-val vreg temp-is-vreg t)))
1543               (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-32-bit-constant-index arch)))
1544                 (cond ((eq type-keyword :single-float-vector)
1545                        (! misc-ref-c-single-float fp-val src index-known-fixnum))
1546                       (t
1547                        (if is-signed
1548                          (! misc-ref-c-s32 temp src index-known-fixnum)
1549                          (! misc-ref-c-u32 temp src index-known-fixnum))))
1550                 (with-imm-target () idx-reg
1551                   (if index-known-fixnum
1552                     (arm2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
1553                     (! scale-32bit-misc-index idx-reg unscaled-idx))
1554                   (cond ((eq type-keyword :single-float-vector)
1555                          (! misc-ref-single-float fp-val src idx-reg))
1556                         (t
1557                          (if is-signed
1558                            (! misc-ref-s32 temp src idx-reg)
1559                            (! misc-ref-u32 temp src idx-reg))))))
1560               (case type-keyword
1561                 (:single-float-vector
1562                  (if (eq vreg-class hard-reg-class-fpr)
1563                    (<- fp-val)
1564                    (ensuring-node-target (target vreg)
1565                      (! single->node target fp-val))))
1566                 (:signed-32-bit-vector
1567                  (unless temp-is-vreg
1568                    (ensuring-node-target (target vreg)
1569                      (arm2-box-s32 seg target temp))))
1570                 (:fixnum-vector
1571                  (unless temp-is-vreg
1572                    (ensuring-node-target (target vreg)
1573                      (! box-fixnum target temp))))
1574                 (:simple-string
1575                  (ensuring-node-target (target vreg)
1576                    (! u32->char target temp)))
1577                 (t
1578                  (unless temp-is-vreg
1579                    (ensuring-node-target (target vreg)
1580                      (arm2-box-u32 seg target temp))))))))
1581          (is-8-bit
1582           (with-imm-target () (temp :u8)
1583             (if (and (eql vreg-class hard-reg-class-gpr)
1584                      (or
1585                       (and is-signed
1586                            (or (eql vreg-mode hard-reg-class-gpr-mode-s8)
1587                                (eql vreg-mode hard-reg-class-gpr-mode-s16)
1588                                (eql vreg-mode hard-reg-class-gpr-mode-s32)
1589                                (eql vreg-mode hard-reg-class-gpr-mode-s64)))
1590                       (and (not is-signed)
1591                            (or (eql vreg-mode hard-reg-class-gpr-mode-u8)
1592                                (eql vreg-mode hard-reg-class-gpr-mode-s16)
1593                                (eql vreg-mode hard-reg-class-gpr-mode-u16)
1594                                (eql vreg-mode hard-reg-class-gpr-mode-s32)
1595                                (eql vreg-mode hard-reg-class-gpr-mode-u32)
1596                                (eql vreg-mode hard-reg-class-gpr-mode-s64)
1597                                (eql vreg-mode hard-reg-class-gpr-mode-u64)))))
1598               (setq temp vreg temp-is-vreg t)
1599               (if is-signed
1600                 (set-regspec-mode temp hard-reg-class-gpr-mode-s8)))
1601             (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-8-bit-constant-index arch)))
1602               (if is-signed
1603                 (! misc-ref-c-s8 temp src index-known-fixnum)
1604                 (! misc-ref-c-u8 temp src index-known-fixnum))
1605               (with-imm-target () idx-reg
1606                 (if index-known-fixnum
1607                   (arm2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) index-known-fixnum))
1608                   (! scale-8bit-misc-index idx-reg unscaled-idx))
1609                 (if is-signed
1610                   (! misc-ref-s8 temp src idx-reg)
1611                   (! misc-ref-u8 temp src idx-reg))))
1612             (ecase type-keyword
1613               (:unsigned-8-bit-vector
1614                (unless temp-is-vreg
1615                  (ensuring-node-target (target vreg)
1616                    (! box-fixnum target temp))))
1617               (:signed-8-bit-vector
1618                (unless temp-is-vreg
1619                  (ensuring-node-target (target vreg)
1620                    (! box-fixnum target temp))))
1621               (:simple-string
1622                (ensuring-node-target (target vreg)
1623                  (! u32->char target temp))))))
1624          (is-16-bit
1625           (ensuring-node-target (target vreg)
1626             (with-imm-target () temp
1627               (if (and index-known-fixnum
1628                        (<= index-known-fixnum (arch::target-max-16-bit-constant-index arch)))
1629                 (if is-signed
1630                   (! misc-ref-c-s16 temp src index-known-fixnum)
1631                   (! misc-ref-c-u16 temp src index-known-fixnum))
1632                 (with-imm-target () idx-reg
1633                   (if index-known-fixnum
1634                     (arm2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1)))
1635                     (! scale-16bit-misc-index idx-reg unscaled-idx))
1636                   (if is-signed
1637                     (! misc-ref-s16 temp src idx-reg)
1638                     (! misc-ref-u16 temp src idx-reg))))
1639               (! box-fixnum target temp))))
1640          (is-64-bit
1641           (with-fp-target () (fp-val :double-float)
1642             (with-imm-target () (temp :u64)
1643               (if (and (eql vreg-class hard-reg-class-fpr)
1644                        (eql vreg-mode hard-reg-class-fpr-mode-double))
1645                 (setq fp-val vreg)
1646                 (if (eql vreg-class hard-reg-class-gpr)
1647                   (if (or (and is-signed
1648                                (eql vreg-mode hard-reg-class-gpr-mode-s64))
1649                           (and (not is-signed)
1650                                (eql vreg-mode hard-reg-class-gpr-mode-u64)))
1651                     (setf temp vreg temp-is-vreg t)
1652                     (if is-signed
1653                       (set-regspec-mode temp hard-reg-class-gpr-mode-s64)))))
1654               (case type-keyword
1655                 (:double-float-vector
1656                  (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1657                    (! misc-ref-c-double-float fp-val src index-known-fixnum)
1658                    (with-imm-target () idx-reg
1659                      (if index-known-fixnum
1660                        (unless unscaled-idx
1661                          (setq unscaled-idx idx-reg)
1662                          (arm2-absolute-natural seg unscaled-idx nil (ash index-known-fixnum arm::fixnumshift))))
1663                      (! misc-ref-double-float fp-val src unscaled-idx)))
1664                  (if (eq vreg-class hard-reg-class-fpr)
1665                    (<- fp-val)
1666                    (ensuring-node-target (target vreg)
1667                      (! double->heap target fp-val))))
1668                 ((:signed-64-bit-vector :fixnum-vector)
1669                  (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1670                    (! misc-ref-c-s64 temp src index-known-fixnum)
1671                    (with-imm-target () idx-reg
1672                      (if index-known-fixnum
1673                        (arm2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3)))
1674                        (! scale-64bit-misc-index idx-reg unscaled-idx))
1675                      (! misc-ref-s64 temp src idx-reg)))
1676                  (if (eq type-keyword :fixnum-vector)
1677                    (ensuring-node-target (target vreg)
1678                      (! box-fixnum target temp))
1679                    (unless temp-is-vreg
1680                      (ensuring-node-target (target vreg)
1681                        (! s64->integer target temp)))))
1682                 (t
1683                  (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1684                    (! misc-ref-c-u64 temp src index-known-fixnum)
1685                    (with-imm-target () idx-reg
1686                      (if index-known-fixnum
1687                        (arm2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3)))
1688                        (! scale-64bit-misc-index idx-reg unscaled-idx))
1689                      (! misc-ref-u64  temp src idx-reg)))
1690                  (unless temp-is-vreg
1691                    (ensuring-node-target (target vreg)
1692                      (! u64->integer target temp))))))))
1693          (t
1694           (unless is-1-bit
1695             (nx-error "~& unsupported vector type: ~s"
1696                       type-keyword))
1697           (ensuring-node-target (target vreg)
1698             (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch)))
1699               (! misc-ref-c-bit-fixnum target src index-known-fixnum)
1700               (with-imm-temps () (word-index bitnum)
1701                 (if index-known-fixnum
1702                   (progn
1703                     (arm2-lri seg word-index (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum -5)))
1704                     (arm2-lri seg bitnum (logand index-known-fixnum #x1f)))
1705                   (! scale-1bit-misc-index word-index bitnum unscaled-idx))
1706                 (let* ((dest word-index))
1707                   (! misc-ref-u32 dest src word-index)
1708                   (! extract-variable-bit-fixnum target dest bitnum)))))))))
1709    (^)))
1710             
1711   
1712
1713;;; safe = T means assume "vector" is miscobj, do bounds check.
1714;;; safe = fixnum means check that subtag of vector = "safe" and do
1715;;;        bounds check.
1716;;; safe = nil means crash&burn.
1717;;; This mostly knows how to reference the elements of an immediate miscobj.
1718(defun arm2-vref (seg vreg xfer type-keyword vector index safe)
1719  (with-arm-local-vinsn-macros (seg vreg xfer)
1720    (let* ((index-known-fixnum (acode-fixnum-form-p index))
1721           (unscaled-idx nil)
1722           (src nil))
1723      (if (or safe (not index-known-fixnum))
1724        (multiple-value-setq (src unscaled-idx)
1725          (arm2-two-untargeted-reg-forms seg vector arm::arg_y index arm::arg_z))
1726        (setq src (arm2-one-untargeted-reg-form seg vector arm::arg_z)))
1727      (when safe
1728        (if (typep safe 'fixnum)
1729          (! trap-unless-typecode= src safe))
1730        (unless index-known-fixnum
1731          (! trap-unless-fixnum unscaled-idx))
1732        (! check-misc-bound unscaled-idx src))
1733      (arm2-vref1 seg vreg xfer type-keyword src unscaled-idx index-known-fixnum))))
1734
1735
1736
1737(defun arm2-aset2 (seg vreg xfer  array i j new safe type-keyword dim0 dim1)
1738  (with-arm-local-vinsn-macros (seg vreg xfer)
1739    (let* ((i-known-fixnum (acode-fixnum-form-p i))
1740           (j-known-fixnum (acode-fixnum-form-p j))
1741           (arch (backend-target-arch *target-backend*))
1742           (is-node (member type-keyword (arch::target-gvector-types arch)))
1743           (constval (arm2-constant-value-ok-for-type-keyword type-keyword new))
1744           (needs-memoization (and is-node (arm2-acode-needs-memoization new)))
1745           (src)
1746           (unscaled-i)
1747           (unscaled-j)
1748           (val-reg (arm2-target-reg-for-aset vreg type-keyword))
1749           (constidx
1750            (and dim0 dim1 i-known-fixnum j-known-fixnum
1751                 (>= i-known-fixnum 0)
1752                 (>= j-known-fixnum 0)
1753                 (< i-known-fixnum dim0)
1754                 (< j-known-fixnum dim1)
1755                 (+ (* i-known-fixnum dim1) j-known-fixnum))))
1756      (progn
1757        (if constidx
1758          (multiple-value-setq (src val-reg)
1759            (arm2-two-targeted-reg-forms seg array ($ arm::temp0) new val-reg))
1760          (multiple-value-setq (src unscaled-i unscaled-j val-reg)
1761            (if needs-memoization
1762              (progn
1763                (arm2-four-targeted-reg-forms seg
1764                                              array ($ arm::temp0)
1765                                              i ($ arm::arg_x)
1766                                              j ($ arm::arg_y)
1767                                              new val-reg)
1768                (values ($ arm::temp0) ($ arm::arg_x) ($ arm::arg_y) ($ arm::arg_z)))
1769              (arm2-four-untargeted-reg-forms seg
1770                                              array ($ arm::temp0)
1771                                              i ($ arm::arg_x)
1772                                              j ($ arm::arg_y)
1773                                              new val-reg))))
1774        (let* ((*available-backend-imm-temps* *available-backend-imm-temps*))
1775          (when (and (= (hard-regspec-class val-reg) hard-reg-class-gpr)
1776                     (logbitp (hard-regspec-value val-reg)
1777                              *backend-imm-temps*))
1778            (use-imm-temp (hard-regspec-value val-reg)))
1779          (when safe     
1780            (when (typep safe 'fixnum)
1781              (let* ((*available-backend-node-temps* *available-backend-node-temps*))
1782                (when unscaled-i
1783                  (use-node-temp (hard-regspec-value unscaled-i)))
1784                (when unscaled-j
1785                  (use-node-temp (hard-regspec-value unscaled-j)))
1786                (with-node-target (src val-reg) expected
1787                  (! lri expected
1788                     (ash (dpb safe target::arrayH.flags-cell-subtag-byte
1789                               (ash 1 $arh_simple_bit))
1790                          arm::fixnumshift))
1791                  (! trap-unless-simple-array-2 src expected))))
1792            (unless i-known-fixnum
1793              (! trap-unless-fixnum unscaled-i))
1794            (unless j-known-fixnum
1795              (! trap-unless-fixnum unscaled-j)))
1796          (with-imm-target () dim1
1797            (let* ((idx-reg ($ arm::arg_y)))
1798              (unless constidx
1799                (if safe                 
1800                  (! check-2d-bound dim1 unscaled-i unscaled-j src)
1801                  (! 2d-dim1 dim1 src))
1802                (! 2d-unscaled-index idx-reg dim1 unscaled-i unscaled-j))
1803              (let* ((v ($ arm::arg_x)))
1804                (! array-data-vector-ref v src)
1805                (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)))))))))
1806
1807
1808(defun arm2-aset3 (seg vreg xfer  array i j k new safe type-keyword  dim0 dim1 dim2)
1809  (with-arm-local-vinsn-macros (seg target)
1810    (let* ((i-known-fixnum (acode-fixnum-form-p i))
1811           (j-known-fixnum (acode-fixnum-form-p j))
1812           (k-known-fixnum (acode-fixnum-form-p k))
1813           (arch (backend-target-arch *target-backend*))
1814           (is-node (member type-keyword (arch::target-gvector-types arch)))
1815           (constval (arm2-constant-value-ok-for-type-keyword type-keyword new))
1816           (needs-memoization (and is-node (arm2-acode-needs-memoization new)))
1817           (src)
1818           (unscaled-i)
1819           (unscaled-j)
1820           (unscaled-k)
1821           (val-reg (arm2-target-reg-for-aset vreg type-keyword))
1822           (constidx
1823            (and dim0 dim1 dim2 i-known-fixnum j-known-fixnum k-known-fixnum
1824                 (>= i-known-fixnum 0)
1825                 (>= j-known-fixnum 0)
1826                 (>= k-known-fixnum 0)
1827                 (< i-known-fixnum dim0)
1828                 (< j-known-fixnum dim1)
1829                 (< k-known-fixnum dim2)
1830                 (+ (* i-known-fixnum dim1 dim2)
1831                    (* j-known-fixnum dim2)
1832                    k-known-fixnum))))
1833      (progn
1834        (if constidx
1835          (multiple-value-setq (src val-reg)
1836            (arm2-two-targeted-reg-forms seg array ($ arm::temp0) new val-reg))
1837          (progn
1838            (setq src ($ arm::temp1)
1839                  unscaled-i ($ arm::temp0)
1840                  unscaled-j ($ arm::arg_x)
1841                  unscaled-k ($ arm::arg_y))
1842            (arm2-push-register
1843             seg
1844             (arm2-one-untargeted-reg-form seg array ($ arm::arg_z)))
1845            (arm2-four-targeted-reg-forms seg
1846                                          i ($ arm::temp0)
1847                                          j ($ arm::arg_x)
1848                                          k ($ arm::arg_y)
1849                                          new val-reg)
1850            (arm2-pop-register seg src)))
1851        (let* ((*available-backend-imm-temps* *available-backend-imm-temps*))
1852          (when (and (= (hard-regspec-class val-reg) hard-reg-class-gpr)
1853                     (logbitp (hard-regspec-value val-reg)
1854                              *backend-imm-temps*))
1855            (use-imm-temp (hard-regspec-value val-reg)))
1856
1857          (when safe     
1858            (when (typep safe 'fixnum)
1859              (let* ((expected (if constidx
1860                                 (with-node-target (src val-reg) expected
1861                                   expected)
1862                                 (with-node-target (src unscaled-i unscaled-j unscaled-k val-reg) expected
1863                                   expected))))
1864                (! lri expected (ash (dpb safe target::arrayH.flags-cell-subtag-byte
1865                                          (ash 1 $arh_simple_bit))
1866                                     arm::fixnumshift))
1867              (! trap-unless-simple-array-3
1868                 src
1869                 expected)))
1870            (unless i-known-fixnum
1871              (! trap-unless-fixnum unscaled-i))
1872            (unless j-known-fixnum
1873              (! trap-unless-fixnum unscaled-j))
1874            (unless k-known-fixnum
1875              (! trap-unless-fixnum unscaled-k)))
1876          (with-imm-target () dim1
1877            (with-imm-target (dim1) dim2
1878              (let* ((idx-reg ($ arm::arg_y)))
1879                (unless constidx
1880                  (if safe                 
1881                    (! check-3d-bound dim1 dim2 unscaled-i unscaled-j unscaled-k src)
1882                    (! 3d-dims dim1 dim2 src))
1883                  (! 3d-unscaled-index idx-reg dim1 dim2 unscaled-i unscaled-j unscaled-k))
1884                (let* ((v ($ arm::arg_x)))
1885                  (! array-data-vector-ref v src)
1886                  (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))))))))))
1887
1888(defun arm2-aref2 (seg vreg xfer array i j safe typekeyword &optional dim0 dim1)
1889  (with-arm-local-vinsn-macros (seg vreg xfer)
1890    (let* ((i-known-fixnum (acode-fixnum-form-p i))
1891           (j-known-fixnum (acode-fixnum-form-p j))
1892           (src)
1893           (unscaled-i)
1894           (unscaled-j)
1895           (constidx
1896            (and dim0 dim1 i-known-fixnum j-known-fixnum
1897                 (>= i-known-fixnum 0)
1898                 (>= j-known-fixnum 0)
1899                 (< i-known-fixnum dim0)
1900                 (< j-known-fixnum dim1)
1901                 (+ (* i-known-fixnum dim1) j-known-fixnum))))
1902      (if constidx
1903        (setq src (arm2-one-targeted-reg-form seg array ($ arm::arg_z)))
1904        (multiple-value-setq (src unscaled-i unscaled-j)
1905          (arm2-three-untargeted-reg-forms seg
1906                                           array arm::arg_x
1907                                           i arm::arg_y
1908                                           j arm::arg_z)))
1909      (when safe       
1910        (when (typep safe 'fixnum)
1911          (let* ((*available-backend-node-temps* *available-backend-node-temps*))
1912            (when unscaled-i
1913              (setq *available-backend-node-temps* (logandc2 *available-backend-node-temps*
1914                                                             (ash 1 (hard-regspec-value unscaled-i)))))
1915            (when unscaled-j
1916              (setq *available-backend-node-temps* (logandc2 *available-backend-node-temps*
1917                                                             (ash 1 (hard-regspec-value unscaled-j)))))
1918            (with-node-target (src) expected
1919              (! lri expected (ash (dpb safe target::arrayH.flags-cell-subtag-byte
1920                                        (ash 1 $arh_simple_bit))
1921                                   arm::fixnumshift))
1922              (! trap-unless-simple-array-2 src expected))))
1923        (unless i-known-fixnum
1924          (! trap-unless-fixnum unscaled-i))
1925        (unless j-known-fixnum
1926          (! trap-unless-fixnum unscaled-j)))
1927      (with-node-target (src) idx-reg
1928        (with-imm-target () dim1
1929          (unless constidx
1930            (if safe                   
1931              (! check-2d-bound dim1 unscaled-i unscaled-j src)
1932              (! 2d-dim1 dim1 src))
1933            (! 2d-unscaled-index idx-reg dim1 unscaled-i unscaled-j))
1934          (with-node-target (idx-reg) v
1935            (! array-data-vector-ref v src)
1936            (arm2-vref1 seg vreg xfer typekeyword v idx-reg constidx)))))))
1937
1938
1939
1940(defun arm2-aref3 (seg vreg xfer array i j k safe typekeyword &optional dim0 dim1 dim2)
1941  (with-arm-local-vinsn-macros (seg vreg xfer)
1942    (let* ((i-known-fixnum (acode-fixnum-form-p i))
1943           (j-known-fixnum (acode-fixnum-form-p j))
1944           (k-known-fixnum (acode-fixnum-form-p k))
1945           (src)
1946           (unscaled-i)
1947           (unscaled-j)
1948           (unscaled-k)
1949           (constidx
1950            (and dim0 dim1 i-known-fixnum j-known-fixnum k-known-fixnum
1951                 (>= i-known-fixnum 0)
1952                 (>= j-known-fixnum 0)
1953                 (>= k-known-fixnum 0)
1954                 (< i-known-fixnum dim0)
1955                 (< j-known-fixnum dim1)
1956                 (< k-known-fixnum dim2)
1957                 (+ (* i-known-fixnum dim1 dim2)
1958                    (* j-known-fixnum dim2)
1959                    k-known-fixnum))))
1960      (if constidx
1961        (setq src (arm2-one-targeted-reg-form seg array ($ arm::arg_z)))
1962        (multiple-value-setq (src unscaled-i unscaled-j unscaled-k)
1963          (arm2-four-untargeted-reg-forms seg
1964                                           array arm::temp0
1965                                           i arm::arg_x
1966                                           j arm::arg_y
1967                                           k arm::arg_z)))
1968      (when safe       
1969        (when (typep safe 'fixnum)
1970          (let* ((expected (if constidx
1971                             (with-node-target (src) expected
1972                               expected)
1973                             (with-node-target (src unscaled-i unscaled-j unscaled-k) expected
1974                               expected))))
1975            (! lri expected (ash (dpb safe target::arrayH.flags-cell-subtag-byte
1976                                      (ash 1 $arh_simple_bit))
1977                                 arm::fixnumshift))
1978            (! trap-unless-simple-array-3 src expected)))
1979        (unless i-known-fixnum
1980          (! trap-unless-fixnum unscaled-i))
1981        (unless j-known-fixnum
1982          (! trap-unless-fixnum unscaled-j))
1983        (unless k-known-fixnum
1984          (! trap-unless-fixnum unscaled-k)))
1985      (with-node-target (src) idx-reg
1986        (with-imm-target () dim1
1987          (with-imm-target (dim1) dim2
1988            (unless constidx
1989              (if safe                   
1990                (! check-3d-bound dim1 dim2 unscaled-i unscaled-j unscaled-k src)
1991                (! 3d-dims dim1 dim2 src))
1992              (! 3d-unscaled-index idx-reg dim1 dim2 unscaled-i unscaled-j unscaled-k))))
1993        (with-node-target (idx-reg) v
1994          (! array-data-vector-ref v src)
1995          (arm2-vref1 seg vreg xfer typekeyword v idx-reg constidx))))))
1996
1997
1998(defun arm2-constant-value-ok-for-type-keyword (type-keyword form)
1999  (if (and (acode-p (setq form (acode-unwrapped-form form)))
2000           (or (eq (acode-operator form) (%nx1-operator immediate))
2001               (eq (acode-operator form) (%nx1-operator fixnum))))
2002    (let* ((val (%cadr form))
2003           (typep (cond ((eq type-keyword :signed-32-bit-vector)
2004                         (typep val '(signed-byte 32)))
2005                        ((eq type-keyword :single-float-vector)
2006                         (typep val 'short-float))
2007                        ((eq type-keyword :double-float-vector)
2008                         (typep val 'double-float))
2009                        ((eq type-keyword :simple-string)
2010                         (typep val 'base-char))
2011                        ((eq type-keyword :signed-8-bit-vector)
2012                         (typep val '(signed-byte 8)))
2013                        ((eq type-keyword :unsigned-8-bit-vector)
2014                         (typep val '(unsigned-byte 8)))
2015                        ((eq type-keyword :signed-16-bit-vector) 
2016                         (typep val '(signed-byte 16)))
2017                        ((eq type-keyword :unsigned-16-bit-vector)
2018                         (typep val '(unsigned-byte 16)))
2019                        ((eq type-keyword :bit-vector)
2020                         (typep val 'bit)))))
2021      (if typep val))))
2022
2023(defun arm2-target-reg-for-aset (vreg type-keyword)
2024  (let* ((arch (backend-target-arch *target-backend*))
2025         (is-node (member type-keyword (arch::target-gvector-types arch)))
2026         (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch)))
2027         (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
2028         (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
2029         (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
2030         (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
2031         (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector)))
2032         (vreg-class (if vreg (hard-regspec-class vreg)))
2033         (vreg-mode (if (or (eql vreg-class hard-reg-class-gpr)
2034                            (eql vreg-class hard-reg-class-fpr))
2035                      (get-regspec-mode vreg)))
2036         (next-imm-target (available-imm-temp  *available-backend-imm-temps*))
2037         (next-fp-target (available-fp-temp *available-backend-fp-temps*))
2038         (acc (make-wired-lreg arm::arg_z)))
2039    (cond ((or is-node
2040               is-1-bit
2041               (eq type-keyword :simple-string)
2042               (eq type-keyword :fixnum-vector)
2043               (and (eql vreg-class hard-reg-class-gpr)
2044                    (eql vreg-mode hard-reg-class-gpr-mode-node)))
2045           acc)
2046          ;; If there's no vreg - if we're setting for effect only, and
2047          ;; not for value - we can target an unboxed register directly.
2048          ;; Usually.
2049          ((null vreg)
2050           (cond (is-64-bit
2051                  (if (eq type-keyword :double-float-vector)
2052                    (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-double)
2053                    (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s64 hard-reg-class-gpr-mode-u64))))
2054                 (is-32-bit
2055                  (if (eq type-keyword :single-float-vector)
2056                    (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-single)
2057                    (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s32 hard-reg-class-gpr-mode-u32))))
2058                 (is-16-bit
2059                  (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s16 hard-reg-class-gpr-mode-u16)))
2060                 (is-8-bit
2061                  (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s8 hard-reg-class-gpr-mode-u8)))
2062                 (t "Bug: can't determine operand size for ~s" type-keyword)))
2063          ;; Vreg is non-null.  We might be able to use it directly.
2064          (t
2065           (let* ((lreg (if vreg-mode
2066                          (make-unwired-lreg (lreg-value vreg)))))
2067             (if 
2068               (cond
2069                 (is-64-bit
2070                  (if (eq type-keyword :double-float-vector)
2071                    (and (eql vreg-class hard-reg-class-fpr)
2072                         (eql vreg-mode hard-reg-class-fpr-mode-double))
2073                      (if is-signed
2074                        (and (eql vreg-class hard-reg-class-gpr)
2075                                 (eql vreg-mode hard-reg-class-gpr-mode-s64))
2076                        (and (eql vreg-class hard-reg-class-gpr)
2077                                 (eql vreg-mode hard-reg-class-gpr-mode-u64)))))
2078                   (is-32-bit
2079                    (if (eq type-keyword :single-float-vector)
2080                      (and (eql vreg-class hard-reg-class-fpr)
2081                               (eql vreg-mode hard-reg-class-fpr-mode-single))
2082                      (if is-signed
2083                        (and (eql vreg-class hard-reg-class-gpr)
2084                                 (or (eql vreg-mode hard-reg-class-gpr-mode-s32)
2085                                     (eql vreg-mode hard-reg-class-gpr-mode-s64)))
2086                        (and (eql vreg-class hard-reg-class-gpr)
2087                                 (or (eql vreg-mode hard-reg-class-gpr-mode-u32)
2088                                     (eql vreg-mode hard-reg-class-gpr-mode-u64)
2089                                     (eql vreg-mode hard-reg-class-gpr-mode-s64))))))
2090                   (is-16-bit
2091                    (if is-signed
2092                      (and (eql vreg-class hard-reg-class-gpr)
2093                               (or (eql vreg-mode hard-reg-class-gpr-mode-s16)
2094                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
2095                                   (eql vreg-mode hard-reg-class-gpr-mode-s64)))
2096                      (and (eql vreg-class hard-reg-class-gpr)
2097                               (or (eql vreg-mode hard-reg-class-gpr-mode-u16)
2098                                   (eql vreg-mode hard-reg-class-gpr-mode-u32)
2099                                   (eql vreg-mode hard-reg-class-gpr-mode-u64)
2100                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
2101                                   (eql vreg-mode hard-reg-class-gpr-mode-s64)))))
2102                   (t
2103                    (if is-signed
2104                      (and (eql vreg-class hard-reg-class-gpr)
2105                               (or (eql vreg-mode hard-reg-class-gpr-mode-s8)
2106                                   (eql vreg-mode hard-reg-class-gpr-mode-s16)
2107                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
2108                                   (eql vreg-mode hard-reg-class-gpr-mode-s64)))
2109                      (and (eql vreg-class hard-reg-class-gpr)
2110                               (or (eql vreg-mode hard-reg-class-gpr-mode-u8)
2111                                   (eql vreg-mode hard-reg-class-gpr-mode-u16)
2112                                   (eql vreg-mode hard-reg-class-gpr-mode-u32)
2113                                   (eql vreg-mode hard-reg-class-gpr-mode-u64)
2114                                   (eql vreg-mode hard-reg-class-gpr-mode-s16)
2115                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
2116                                   (eql vreg-mode hard-reg-class-gpr-mode-s64))))))
2117               lreg
2118               acc))))))
2119
2120(defun arm2-unboxed-reg-for-aset (seg type-keyword result-reg safe constval)
2121  (with-arm-local-vinsn-macros (seg)
2122    (let* ((arch (backend-target-arch *target-backend*))
2123           (is-node (member type-keyword (arch::target-gvector-types arch)))
2124           (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
2125           (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
2126           (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
2127           (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
2128           (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector)))
2129           (result-is-node-gpr (and (eql (hard-regspec-class result-reg)
2130                                         hard-reg-class-gpr)
2131                                    (eql (get-regspec-mode result-reg)
2132                                         hard-reg-class-gpr-mode-node)))
2133           (next-imm-target (available-imm-temp *available-backend-imm-temps*))
2134           (next-fp-target (available-fp-temp *available-backend-fp-temps*)))
2135      (if (or is-node (not result-is-node-gpr))
2136        result-reg
2137        (cond (is-64-bit
2138               (if (eq type-keyword :double-float-vector)
2139                 (let* ((reg (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-double)))
2140                   (if safe
2141                     (! get-double? reg result-reg)
2142                     (! get-double reg result-reg))
2143                   reg)))
2144              (is-32-bit
2145               ;; Generally better to use a GPR for the :SINGLE-FLOAT-VECTOR
2146               ;; case here.
2147               (if is-signed             
2148                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s32)))
2149                   (if (eq type-keyword :fixnum-vector)
2150                     (progn
2151                       (when safe
2152                         (! trap-unless-fixnum result-reg))
2153                       (! fixnum->signed-natural reg result-reg))
2154                     (! unbox-s32 reg result-reg))
2155                   reg)
2156                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u32)))
2157                   (cond ((eq type-keyword :simple-string)
2158                          (if (characterp constval)
2159                            (arm2-lri seg reg (char-code constval))
2160                            (! unbox-base-char reg result-reg)))
2161                         ((eq type-keyword :single-float-vector)
2162                          (if (typep constval 'single-float)
2163                            (arm2-lri seg reg (single-float-bits constval))
2164                            (progn
2165                              (when safe
2166                                (! trap-unless-single-float result-reg))
2167                              (! single-float-bits reg result-reg))))
2168                         (t
2169                          (if (typep constval '(unsigned-byte 32))
2170                            (arm2-lri seg reg constval)
2171                            (! unbox-u32 reg result-reg))))
2172                   reg)))
2173              (is-16-bit
2174               (if is-signed
2175                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s16)))
2176                   (if (typep constval '(signed-byte 16))
2177                     (arm2-lri seg reg constval)
2178                     (! unbox-s16 reg result-reg))
2179                   reg)
2180                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u16)))
2181                   (if (typep constval '(unsigned-byte 16))
2182                     (arm2-lri seg reg constval)
2183                     (! unbox-u16 reg result-reg))
2184                   reg)))
2185              (is-8-bit
2186               (if is-signed
2187                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s8)))
2188                   (if (typep constval '(signed-byte 8))
2189                     (arm2-lri seg reg constval)
2190                     (! unbox-s8 reg result-reg))
2191                   reg)
2192                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u8)))
2193                   (if (typep constval '(unsigned-byte 8))
2194                     (arm2-lri seg reg constval)
2195                     (! unbox-u8 reg result-reg))
2196                   reg)))
2197              (t
2198                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u8)))
2199                   (unless (typep constval 'bit)
2200                     (! unbox-bit reg result-reg))
2201                   reg)))))))
2202                   
2203     
2204;;; "val-reg" might be boxed, if the vreg requires it to be.
2205(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))
2206  (with-arm-local-vinsn-macros (seg vreg xfer)
2207    (let* ((arch (backend-target-arch *target-backend*))
2208           (is-node (member type-keyword (arch::target-gvector-types arch)))
2209           (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch)))
2210           (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
2211           (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
2212           (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
2213           (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
2214           (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector))))
2215      (cond ((and is-node node-value-needs-memoization)
2216             (unless (and (eql (hard-regspec-value src) arm::arg_x)
2217                          (eql (hard-regspec-value unscaled-idx) arm::arg_y)
2218                          (eql (hard-regspec-value val-reg) arm::arg_z))
2219               (compiler-bug "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg)))
2220             (! call-subprim-3 val-reg (arm::arm-subprimitive-offset '.SPgvset) src unscaled-idx val-reg))
2221            (is-node
2222             (if (and index-known-fixnum (<= index-known-fixnum
2223                                             (arch::target-max-32-bit-constant-index arch)))
2224               (! misc-set-c-node val-reg src index-known-fixnum)
2225               (with-imm-target () scaled-idx
2226
2227                 (if index-known-fixnum
2228                   (arm2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum *arm2-target-node-shift*)))
2229                   (! scale-node-misc-index scaled-idx unscaled-idx))
2230                 (! misc-set-node val-reg src scaled-idx))))
2231            (t
2232             (cond
2233               (is-64-bit
2234                (with-imm-target (arm::imm0 arm::imm1) scaled-idx
2235                  (if (and index-known-fixnum
2236                           (<= index-known-fixnum
2237                               (arch::target-max-64-bit-constant-index arch)))
2238                    (! misc-set-c-double-float unboxed-val-reg src index-known-fixnum)
2239                    (progn
2240                      (if index-known-fixnum
2241                        (unless unscaled-idx
2242                          (setq unscaled-idx scaled-idx)
2243                          (arm2-absolute-natural seg unscaled-idx nil (ash index-known-fixnum arm::fixnumshift))))
2244                      (! misc-set-double-float unboxed-val-reg src unscaled-idx)))))
2245                 (t
2246                  (with-imm-target (unboxed-val-reg) scaled-idx
2247                    (cond
2248                      (is-32-bit
2249                       (if (and index-known-fixnum
2250                                (<= index-known-fixnum
2251                                    (arch::target-max-32-bit-constant-index arch)))
2252                         (if (eq type-keyword :single-float-vector)
2253                           (if (eq (hard-regspec-class unboxed-val-reg)
2254                                   hard-reg-class-fpr)
2255                             (! misc-set-c-single-float unboxed-val-reg src index-known-fixnum)
2256                             (! misc-set-c-u32 unboxed-val-reg src index-known-fixnum))
2257                           (if is-signed
2258                             (! misc-set-c-s32 unboxed-val-reg src index-known-fixnum)
2259                             (! misc-set-c-u32 unboxed-val-reg src index-known-fixnum)))
2260                         (progn
2261                           (if index-known-fixnum
2262                             (arm2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
2263                             (! scale-32bit-misc-index scaled-idx unscaled-idx))
2264                           (if (and (eq type-keyword :single-float-vector)
2265                                    (eql (hard-regspec-class unboxed-val-reg)
2266                                         hard-reg-class-fpr))
2267                             (! misc-set-single-float unboxed-val-reg src scaled-idx)
2268                             (if is-signed
2269                               (! misc-set-s32 unboxed-val-reg src scaled-idx)
2270                               (! misc-set-u32 unboxed-val-reg src scaled-idx))))))
2271                      (is-16-bit
2272                       (if (and index-known-fixnum
2273                                (<= index-known-fixnum
2274                                    (arch::target-max-16-bit-constant-index arch)))
2275                         (if is-signed
2276                           (! misc-set-c-s16 unboxed-val-reg src index-known-fixnum)
2277                           (! misc-set-c-u16 unboxed-val-reg src index-known-fixnum))
2278                         (progn
2279                           (if index-known-fixnum
2280                             (arm2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1)))
2281                             (! scale-16bit-misc-index scaled-idx unscaled-idx))
2282                           (if is-signed
2283                             (! misc-set-s16 unboxed-val-reg src scaled-idx)
2284                             (! misc-set-u16 unboxed-val-reg src scaled-idx)))))
2285                      (is-8-bit
2286                       (if (and index-known-fixnum
2287                                (<= index-known-fixnum
2288                                    (arch::target-max-8-bit-constant-index arch)))
2289                         (if is-signed
2290                           (! misc-set-c-s8 unboxed-val-reg src index-known-fixnum)
2291                           (! misc-set-c-u8  unboxed-val-reg src index-known-fixnum))
2292                         (progn
2293                           (if index-known-fixnum
2294                             (arm2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) index-known-fixnum))
2295                             (! scale-8bit-misc-index scaled-idx unscaled-idx))
2296                           (if is-signed
2297                             (! misc-set-s8 unboxed-val-reg src scaled-idx)
2298                             (! misc-set-u8 unboxed-val-reg src scaled-idx)))))
2299                      (t
2300                       (unless is-1-bit
2301                         (nx-error "~& unsupported vector type: ~s"
2302                                   type-keyword))
2303                       (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch)))
2304                         (with-imm-target (unboxed-val-reg) word
2305                           (let* ((word-index (ash index-known-fixnum -5))
2306                                  (bit-number (logand index-known-fixnum #x1f)))
2307                             (! misc-ref-c-u32 word src word-index)
2308                             (if constval
2309                               (if (zerop constval)
2310                                 (! set-constant-arm-bit-to-0 word word bit-number)
2311                                 (! set-constant-arm-bit-to-1 word word bit-number))
2312                               (! set-constant-arm-bit-to-variable-value word word unboxed-val-reg bit-number))
2313                             (! misc-set-c-u32 word src word-index)))
2314                         (with-crf-target () crf
2315                           (with-imm-temps () (word-index bit-number temp)
2316                             (unless constval
2317                               (! compare-immediate crf unboxed-val-reg 0))
2318                             (! scale-1bit-misc-index word-index bit-number unscaled-idx)
2319                             (! lri temp 1)
2320                             (! shift-left-variable-word bit-number temp bit-number)
2321                             (! misc-ref-u32 temp src word-index)
2322                             (if constval
2323                               (if (zerop constval)
2324                                 (! u32logandc2 temp temp bit-number)
2325                                 (! u32logior temp temp bit-number))
2326                               (progn
2327                                 (! set-or-clear-bit temp temp bit-number crf)))
2328                             (! misc-set-u32 temp src word-index)))))))))))
2329      (when (and vreg val-reg) (<- val-reg))
2330    (^))))
2331                   
2332
2333(defun arm2-code-coverage-entry (seg note)
2334  (let* ((afunc *arm2-cur-afunc*))
2335    (setf (afunc-bits afunc) (%ilogior (afunc-bits afunc) (ash 1 $fbitccoverage)))
2336    (with-arm-local-vinsn-macros (seg)
2337      (let* ((ccreg ($ arm::temp0)))
2338        (arm2-store-immediate seg note ccreg)
2339        (with-node-temps (ccreg) (zero)
2340          (! lri zero 0)
2341          (! misc-set-c-node zero ccreg 1))))))
2342
2343(defun arm2-vset (seg vreg xfer type-keyword vector index value safe)
2344  (with-arm-local-vinsn-macros (seg)
2345    (let* ((arch (backend-target-arch *target-backend*))
2346           (is-node (member type-keyword (arch::target-gvector-types arch)))
2347           (constval (arm2-constant-value-ok-for-type-keyword type-keyword value))
2348           (needs-memoization (and is-node (arm2-acode-needs-memoization value)))
2349           (index-known-fixnum (acode-fixnum-form-p index)))
2350      (let* ((src ($ arm::arg_x))
2351             (unscaled-idx ($ arm::arg_y))
2352             (result-reg ($ arm::arg_z)))
2353        (cond (needs-memoization
2354               (arm2-three-targeted-reg-forms seg
2355                                              vector src
2356                                              index unscaled-idx
2357                                              value result-reg))
2358              (t
2359               (if (and (not safe) index-known-fixnum)
2360                 (multiple-value-setq (src result-reg unscaled-idx)
2361                   (arm2-two-untargeted-reg-forms seg
2362                                                  vector src
2363                                                  value (arm2-target-reg-for-aset vreg type-keyword)))
2364                 (multiple-value-setq (src unscaled-idx result-reg)
2365                   (arm2-three-untargeted-reg-forms seg
2366                                                    vector src
2367                                                    index unscaled-idx
2368                                                    value (arm2-target-reg-for-aset vreg type-keyword))))))
2369        (when safe
2370          (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)
2371                 (value (if (eql (hard-regspec-class result-reg)
2372                                 hard-reg-class-gpr)
2373                          (hard-regspec-value result-reg))))
2374            (when (and value (logbitp value *available-backend-imm-temps*))
2375              (setq *available-backend-imm-temps* (bitclr value *available-backend-imm-temps*)))
2376            (if (typep safe 'fixnum)
2377              (! trap-unless-typecode= src safe))
2378            (unless index-known-fixnum
2379              (! trap-unless-fixnum unscaled-idx))
2380            (! check-misc-bound unscaled-idx src)))
2381        (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)))))
2382
2383
2384(defun arm2-tail-call-alias (immref sym &optional arglist)
2385  (let ((alias (cdr (assq sym *arm2-tail-call-aliases*))))
2386    (if (and alias (or (null arglist) (eq (+ (length (car arglist)) (length (cadr arglist))) (cdr alias))))
2387      (make-acode (%nx1-operator immediate) (car alias))
2388      immref)))
2389
2390;;; If BODY is essentially an APPLY involving an &rest arg, try to avoid
2391;;; consing it.
2392(defun arm2-eliminate-&rest (body rest key-p auxen rest-values)
2393  (when (and rest (not key-p) (not (cadr auxen)) rest-values)
2394    (when (eq (logand (the fixnum (nx-var-bits rest))
2395                      (logior (ash -1 $vbitspecial)
2396                              (ash 1 $vbitclosed) (ash 1 $vbitsetq) (ash 1 $vbitcloseddownward)))
2397              0)               ; Nothing but simple references
2398      (do* ()
2399           ((not (acode-p body)))
2400        (let* ((op (acode-operator body)))
2401          (if (or (eq op (%nx1-operator lexical-function-call))
2402                  (eq op (%nx1-operator call)))
2403            (destructuring-bind (fn-form (stack-args reg-args) &optional spread-p) (%cdr body)
2404               (unless (and (eq spread-p t)
2405                           (eq (arm2-lexical-reference-p (%car reg-args)) rest))
2406                (return nil))
2407              (flet ((independent-of-all-values (form)       
2408                       (setq form (acode-unwrapped-form-value form))
2409                       (or (arm-constant-form-p form)
2410                           (let* ((lexref (arm2-lexical-reference-p form)))
2411                             (and lexref 
2412                                  (neq lexref rest)
2413                                  (dolist (val rest-values t)
2414                                    (unless (arm2-var-not-set-by-form-p lexref val)
2415                                      (return))))))))
2416                (unless (or (eq op (%nx1-operator lexical-function-call))
2417                            (independent-of-all-values fn-form))
2418                  (return nil))
2419                (if (dolist (s stack-args t)
2420                          (unless (independent-of-all-values s)
2421                            (return nil)))
2422                  (let* ((arglist (append stack-args rest-values)))
2423                    (return
2424                     (make-acode op 
2425                                 fn-form 
2426                                 (if (<= (length arglist) $numarmargregs)
2427                                   (list nil (reverse arglist))
2428                                   (list (butlast arglist $numarmargregs)
2429                                         (reverse (last arglist $numarmargregs))))
2430                                 nil)))
2431                  (return nil))))
2432            (if (eq op (%nx1-operator local-block))
2433              (setq body (%cadr body))
2434              (if (and (eq op (%nx1-operator if))
2435                       (eq (arm2-lexical-reference-p (%cadr body)) rest))
2436                (setq body (%caddr body))
2437                (return nil)))))))))
2438
2439(defun arm2-call-fn (seg vreg xfer fn arglist spread-p)
2440  (with-arm-local-vinsn-macros (seg vreg xfer)
2441    (when spread-p
2442      (destructuring-bind (stack-args reg-args) arglist
2443        (when (and (null (cdr reg-args))
2444                   (nx-null (acode-unwrapped-form-value (car reg-args))))
2445          (setq spread-p nil)
2446          (let* ((nargs (length stack-args)))
2447            (declare (fixnum nargs))
2448            (if (<= nargs $numarmargregs)
2449              (setq arglist (list nil (reverse stack-args)))
2450              (setq arglist (list (butlast stack-args $numarmargregs) (reverse (last stack-args $numarmargregs)))))))))
2451    (let* ((lexref (arm2-lexical-reference-p fn))
2452           (simple-case (or (fixnump fn)
2453                            (typep fn 'lreg)
2454                            (arm2-immediate-function-p fn)
2455                            (and 
2456                             lexref
2457                             (not spread-p)
2458                             (flet ((all-simple (args)
2459                                      (dolist (arg args t)
2460                                        (when (and arg (not (arm2-var-not-set-by-form-p lexref arg)))
2461                                          (return)))))
2462                               (and (all-simple (car arglist))
2463                                    (all-simple (cadr arglist))
2464                                    (setq fn (var-ea lexref)))))))
2465           (cstack *arm2-cstack*)
2466           (top *arm2-top-vstack-lcell*)
2467           (vstack *arm2-vstack*))
2468      (setq xfer (or xfer 0))
2469      (when (and (eq xfer $backend-return)
2470                 (eq 0 *arm2-undo-count*)
2471                 (acode-p fn)
2472                 (eq (acode-operator fn) (%nx1-operator immediate))
2473                 (symbolp (cadr fn)))
2474        (setq fn (arm2-tail-call-alias fn (%cadr fn) arglist)))
2475     
2476      (if (and (eq xfer $backend-return) (not (arm2-tailcallok xfer)))
2477        (progn
2478          (arm2-call-fn seg vreg $backend-mvpass fn arglist spread-p)
2479          (arm2-set-vstack (%i+ (if simple-case 0 *arm2-target-node-size*) vstack))
2480          (setq  *arm2-cstack* cstack)
2481          (let ((*arm2-returning-values* t)) (arm2-do-return seg)))
2482        (let* ((mv-p (arm2-mv-p xfer)))
2483          (unless simple-case
2484            (arm2-vpush-register seg (arm2-one-untargeted-reg-form seg fn arm::arg_z))
2485            (setq fn (arm2-vloc-ea vstack)))
2486          (arm2-invoke-fn seg fn (arm2-arglist seg arglist) spread-p xfer)
2487          (if (and (logbitp $backend-mvpass-bit xfer)
2488                   (not simple-case))
2489            (progn
2490              (! save-values)
2491              (! vstack-discard 1)
2492              (arm2-set-nargs seg 0)
2493              (! recover-values))
2494            (unless (or mv-p simple-case)
2495              (! vstack-discard 1)))
2496          (arm2-set-vstack vstack)
2497          (setq *arm2-top-vstack-lcell* top)
2498          (setq *arm2-cstack* cstack)
2499          (when (or (logbitp $backend-mvpass-bit xfer) (not mv-p))
2500            (<- arm::arg_z)
2501            (arm2-branch seg (logand (lognot $backend-mvpass-mask) xfer) vreg))))
2502      nil)))
2503
2504(defun arm2-restore-full-lisp-context (seg)
2505  (with-arm-local-vinsn-macros (seg)
2506    (! restore-full-lisp-context)))
2507
2508(defun arm2-call-symbol (seg jump-p)
2509  ; fname contains a symbol; we can either call it via
2510  ; a call to .SPjmpsym or expand the instructions inline.
2511  ; Since the branches are unconditional, the call doesn't
2512  ; cost much, but doing the instructions inline would give
2513  ; an instruction scheduler some opportunities to improve
2514  ; performance, so this isn't a strict time/speed tradeoff.
2515  ; This should probably dispatch on something other than
2516  ; *arm2-open-code-inline*, since that does imply a time/speed
2517  ; tradeoff.
2518  (with-arm-local-vinsn-macros (seg)
2519    (if *arm2-optimize-for-space*
2520      (if jump-p
2521        (! jump-known-symbol-ool)
2522        (! call-known-symbol-ool))
2523      (if jump-p
2524        (! jump-known-symbol)
2525        (! call-known-symbol arm::arg_z)))))
2526
2527;;; Nargs = nil -> multiple-value case.
2528(defun arm2-invoke-fn (seg fn nargs spread-p xfer)
2529  (with-arm-local-vinsn-macros (seg)
2530    (let* ((f-op (acode-unwrapped-form-value fn))
2531           (immp (and (consp f-op)
2532                      (eq (%car f-op) (%nx1-operator immediate))))
2533           (symp (and immp (symbolp (%cadr f-op))))
2534           (label-p (and (fixnump fn) 
2535                         (locally (declare (fixnum fn))
2536                           (and (= fn -1) (- fn)))))
2537           (tail-p (eq xfer $backend-return))
2538           (func (if (consp f-op) (%cadr f-op)))
2539           (a-reg nil)
2540           (lfunp (and (acode-p f-op) 
2541                       (eq (acode-operator f-op) (%nx1-operator simple-function))))
2542           (expression-p (or (typep fn 'lreg) (and (fixnump fn) (not label-p))))
2543           (callable (or symp lfunp label-p))
2544           (destreg (if symp ($ arm::fname) (if lfunp ($ arm::nfn) (unless label-p ($ arm::nfn)))))
2545           (known-fixed-nargs nil)
2546           (label (when label-p
2547                    (if (and *arm2-fixed-args-label*
2548                             (eql nargs *arm2-fixed-nargs*)
2549                             (not spread-p)
2550                             (not (arm2-mvpass-p xfer)))
2551                      (progn
2552                        (setq known-fixed-nargs t)
2553                        (if tail-p
2554                          *arm2-fixed-args-tail-label*
2555                          *arm2-fixed-args-label*))
2556                      1))))
2557      (when expression-p
2558        ;;Have to do this before spread args, since might be vsp-relative.
2559        (if nargs
2560          (arm2-do-lexical-reference seg destreg fn)
2561          (arm2-copy-register seg destreg fn)))
2562      (if (or symp lfunp)
2563        (setq func (if symp (arm2-symbol-entry-locative func)
2564                     (arm2-afunc-lfun-ref func))
2565              a-reg (arm2-register-constant-p func)))
2566      (when tail-p
2567        #-no-compiler-bugs
2568        (unless (or immp symp lfunp (typep fn 'lreg) (fixnump fn)) (compiler-bug "Well, well, well.  How could this have happened ?"))
2569        (when a-reg
2570          (arm2-copy-register seg destreg a-reg))
2571        (unless spread-p
2572          (arm2-restore-nvrs seg (null nargs))
2573          (arm2-restore-non-volatile-fprs seg)))
2574      (if spread-p
2575        (progn
2576          (arm2-set-nargs seg (%i- nargs 1))
2577          (if (eq spread-p 0)
2578            (! spread-lexpr)
2579            (! spread-list))
2580          (arm2-restore-nvrs seg nil)
2581          (arm2-restore-non-volatile-fprs seg))
2582        (if nargs
2583          (unless known-fixed-nargs (arm2-set-nargs seg nargs))
2584          (! pop-argument-registers)))
2585      (if callable
2586        (if (not tail-p)
2587          (if (arm2-mvpass-p xfer)
2588            (let* ((call-reg (if symp ($ arm::fname) ($ arm::nfn))))
2589              (if label-p
2590                (arm2-copy-register seg call-reg ($ arm::fn))
2591                (if a-reg
2592                  (arm2-copy-register seg call-reg  a-reg)
2593                  (arm2-store-immediate seg func call-reg)))
2594              (if symp
2595                (! pass-multiple-values-symbol)
2596                (! pass-multiple-values)))
2597            (progn 
2598              (if label-p
2599                (progn
2600                  (arm2-copy-register seg ($ arm::nfn) ($  arm::fn))
2601                  (! call-label (aref *backend-labels* label)))
2602                (progn
2603                  (if a-reg
2604                    (arm2-copy-register seg destreg a-reg)
2605                    (arm2-store-immediate seg func destreg))
2606                  (if symp
2607                    (arm2-call-symbol seg nil)
2608                    (! call-known-function))))))
2609          (progn
2610            (arm2-unwind-stack seg xfer 0 0 #x7fffff)
2611            (if (and (not spread-p) nargs (%i<= nargs $numarmargregs))
2612              (progn
2613                (if label-p
2614                  (unless known-fixed-nargs
2615                    (arm2-copy-register seg arm::nfn arm::fn)))
2616                (unless (or label-p a-reg) (arm2-store-immediate seg func destreg))
2617                (unless known-fixed-nargs
2618                  (arm2-restore-full-lisp-context seg))
2619                (if label-p
2620                  (! jump (aref *backend-labels* label))
2621                  (progn
2622                    (if symp
2623                      (arm2-call-symbol seg t)
2624                      (! jump-known-function)))))
2625              (progn
2626                (if label-p
2627                  (arm2-copy-register seg arm::nfn arm::fn)
2628                  (unless a-reg (arm2-store-immediate seg func destreg)))
2629                (cond ((or spread-p (null nargs))
2630                       (if symp
2631                         (! tail-call-sym-gen)
2632                         (! tail-call-fn-gen)))
2633                      ((%i> nargs $numarmargregs)
2634                       (if symp
2635                         (! tail-call-sym-slide)
2636                         (! tail-call-fn-slide)))
2637                      (t
2638                       (! restore-full-lisp-context)
2639                       (if symp
2640                         (! jump-known-symbol)
2641                         (! jump-known-function))))))))
2642        ;; The general (funcall) case: we don't know (at compile-time)
2643        ;; for sure whether we've got a symbol or a (local, constant)
2644        ;; function.
2645        (progn
2646          (unless (or (fixnump fn) (typep fn 'lreg))
2647            (arm2-one-targeted-reg-form seg fn destreg))
2648          (if (not tail-p)
2649            (if (arm2-mvpass-p xfer)
2650              (! pass-multiple-values)
2651              (! funcall))                 
2652            (cond ((or (null nargs) spread-p)
2653                   (! tail-funcall-gen))
2654                  ((%i> nargs $numarmargregs)
2655                   (! tail-funcall-slide))
2656                  (t
2657                   (! tail-funcall-vsp)))))))
2658    nil))
2659
2660(defun arm2-seq-fbind (seg vreg xfer vars afuncs body p2decls)
2661  (let* ((old-stack (arm2-encode-stack))
2662         (copy afuncs)
2663         (func nil))
2664    (with-arm-p2-declarations p2decls 
2665      (dolist (var vars) 
2666        (when (neq 0 (afunc-fn-refcount (setq func (pop afuncs))))
2667          (arm2-seq-bind-var seg var (nx1-afunc-ref func))))
2668      (arm2-undo-body seg vreg xfer body old-stack)
2669      (dolist (var vars)
2670        (when (neq 0 (afunc-fn-refcount (setq func (pop copy))))
2671          (arm2-close-var seg var))))))
2672
2673(defun arm2-make-closure (seg afunc downward-p)
2674  (with-arm-local-vinsn-macros (seg)
2675    (flet ((var-to-reg (var target)
2676             (let* ((ea (var-ea (var-bits var))))
2677               (if ea
2678                 (arm2-addrspec-to-reg seg (arm2-ea-open ea) target)
2679                 (! load-nil target))
2680               target))
2681           (set-some-cells (dest cellno c0 c1 c2 c3)
2682             (declare (fixnum cellno))
2683             (! misc-set-c-node c0 dest cellno)
2684             (incf cellno)
2685             (when c1
2686               (! misc-set-c-node c1 dest cellno)
2687               (incf cellno)
2688               (when c2
2689                 (! misc-set-c-node c2 dest cellno)
2690                 (incf cellno)
2691                 (when c3
2692                   (! misc-set-c-node c3 dest cellno)
2693                   (incf cellno))))
2694             cellno))
2695      (let* ((inherited-vars (afunc-inherited-vars afunc))
2696             (arch (backend-target-arch *target-backend*))
2697             (dest ($ arm::arg_z))
2698             (vsize (+ (length inherited-vars) 
2699                       3                ; entrypoint,%closure-code%, afunc
2700                       2)))             ; name, lfun-bits
2701        (declare (list inherited-vars))
2702        (if downward-p
2703          (progn
2704            (let* ((*arm2-vstack* *arm2-vstack*)
2705                   (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*))
2706              (arm2-lri seg arm::arg_x (ash (nx-lookup-target-uvector-subtag :function) *arm2-target-fixnum-shift*))
2707              (arm2-lri seg arm::temp0 0)
2708              (! %closure-code% arm::arg_y)
2709              (arm2-store-immediate seg (arm2-afunc-lfun-ref afunc) arm::arg_z)
2710              (arm2-vpush-register-arg seg arm::arg_x)
2711              (arm2-vpush-register-arg seg arm::temp0)
2712              (arm2-vpush-register-arg seg arm::arg_y)
2713              (arm2-vpush-register-arg seg arm::arg_z)
2714              ;; Could be smarter about memory traffic here.
2715              (dolist (v inherited-vars)
2716                (arm2-vpush-register-arg seg (var-to-reg v arm::arg_z)))
2717              (! load-nil arm::arg_z)
2718              (arm2-vpush-register-arg seg arm::arg_z)
2719              (arm2-lri seg arm::arg_z (ash (ash 1 $lfbits-trampoline-bit) *arm2-target-fixnum-shift*))
2720              (arm2-vpush-register-arg seg arm::arg_z)
2721              (arm2-set-nargs seg (1+ vsize)) ; account for subtag
2722              (! make-stack-closure))
2723            (arm2-open-undo $undostkblk))
2724          (let* ((cell 1))
2725            (declare (fixnum cell))
2726            (progn
2727              (arm2-lri seg
2728                        arm::imm0
2729                        (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function)))
2730              (! %alloc-misc-fixed dest arm::imm0 (ash vsize (arch::target-word-shift arch)))
2731              )
2732            (! %closure-code% arm::arg_x)
2733            (! %codevector-entry arm::lr arm::arg_x)
2734            (! misc-set-c-node arm::lr dest 0)
2735            (arm2-store-immediate seg (arm2-afunc-lfun-ref afunc) arm::arg_y)
2736            (with-node-temps (arm::arg_z) (t0 t1 t2 t3)
2737              (do* ((ccode arm::arg_x nil)
2738                    (func arm::arg_y nil))
2739                   ((null inherited-vars))
2740                (let* ((t0r (or ccode (if inherited-vars (var-to-reg (pop inherited-vars) t0))))
2741                       (t1r (or func (if inherited-vars (var-to-reg (pop inherited-vars) t1))))
2742                       (t2r (if inherited-vars (var-to-reg (pop inherited-vars) t2)))
2743                       (t3r (if inherited-vars (var-to-reg (pop inherited-vars) t3))))
2744                  (setq cell (set-some-cells dest cell t0r t1r t2r t3r)))))
2745            (arm2-lri seg arm::arg_y (ash (ash 1 $lfbits-trampoline-bit) *arm2-target-fixnum-shift*))
2746            (! load-nil arm::arg_x)
2747            (! misc-set-c-node arm::arg_x dest cell)
2748            (! misc-set-c-node arm::arg_y dest (1+ cell))))
2749        dest))))
2750       
2751(defun arm2-symbol-entry-locative (sym)
2752  (setq sym (require-type sym 'symbol))
2753  (when (eq sym '%call-next-method-with-args)
2754    (setf (afunc-bits *arm2-cur-afunc*)
2755          (%ilogior (%ilsl $fbitnextmethargsp 1) (afunc-bits *arm2-cur-afunc*))))
2756  (or (assq sym *arm2-fcells*)
2757      (let ((new (list sym)))
2758        (push new *arm2-fcells*)
2759        new)))
2760
2761(defun arm2-symbol-value-cell (sym)
2762  (setq sym (require-type sym 'symbol))
2763  (or (assq sym *arm2-vcells*)
2764      (let ((new (list sym)))
2765        (push new *arm2-vcells*)
2766        (ensure-binding-index sym)
2767        new)))
2768
2769
2770(defun arm2-symbol-locative-p (imm)
2771  (and (consp imm)
2772       (or (memq imm *arm2-vcells*)
2773           (memq imm *arm2-fcells*))))
2774
2775
2776
2777
2778(defun arm2-immediate-function-p (f)
2779  (setq f (acode-unwrapped-form-value f))
2780  (and (acode-p f)
2781       (or (eq (%car f) (%nx1-operator immediate))
2782           (eq (%car f) (%nx1-operator simple-function)))))
2783
2784(defun arm-constant-form-p (form)
2785  (setq form (nx-untyped-form form))
2786  (if form
2787    (or (nx-null form)
2788        (nx-t form)
2789        (and (consp form)
2790             (or (eq (acode-operator form) (%nx1-operator immediate))
2791                 (eq (acode-operator form) (%nx1-operator fixnum))
2792                 (eq (acode-operator form) (%nx1-operator simple-function)))))))
2793
2794
2795 
2796(defun arm2-integer-constant-p (form mode)
2797  (let* ((val 
2798         (or (acode-fixnum-form-p (setq form (acode-unwrapped-form form)))
2799             (and (acode-p form)
2800                  (eq (acode-operator form) (%nx1-operator immediate))
2801                  (setq form (%cadr form))
2802                  (if (typep form 'integer)
2803                    form)))))
2804    (and val (%typep val (mode-specifier-type mode)) val)))
2805
2806
2807(defun arm-side-effect-free-form-p (form)
2808  (when (consp (setq form (acode-unwrapped-form-value form)))
2809    (or (arm-constant-form-p form)
2810        ;(eq (acode-operator form) (%nx1-operator bound-special-ref))
2811        (if (eq (acode-operator form) (%nx1-operator lexical-reference))
2812          (not (%ilogbitp $vbitsetq (nx-var-bits (%cadr form))))))))
2813
2814(defun arm2-formlist (seg stkargs &optional revregargs)
2815  (with-arm-local-vinsn-macros (seg) 
2816    (let* ((nregs (length revregargs))
2817           (n nregs))
2818      (declare (fixnum n))
2819      (dolist (arg stkargs)
2820        (let* ((reg (arm2-one-untargeted-reg-form seg arg arm::arg_z)))
2821          (arm2-vpush-register-arg seg reg)
2822          (incf n)))
2823      (when revregargs
2824        (let* ((zform (%car revregargs))
2825               (yform (%cadr revregargs))
2826               (xform (%caddr revregargs)))
2827          (if (eq 3 nregs)
2828            (arm2-three-targeted-reg-forms seg xform ($ arm::arg_x) yform ($ arm::arg_y) zform ($ arm::arg_z))
2829            (if (eq 2 nregs)
2830              (arm2-two-targeted-reg-forms seg yform ($ arm::arg_y) zform ($ arm::arg_z))
2831              (arm2-one-targeted-reg-form seg zform ($ arm::arg_z))))))
2832      n)))
2833
2834(defun arm2-arglist (seg args)
2835  (arm2-formlist seg (car args) (cadr args)))
2836
2837
2838
2839
2840
2841(defun arm2-unboxed-integer-arg-to-reg (seg form immreg &optional ffi-arg-type)
2842  (let* ((mode (case ffi-arg-type
2843                 ((nil) :natural)
2844                 (:signed-byte :s8)
2845                 (:unsigned-byte :u8)
2846                 (:signed-halfword :s16)
2847                 (:unsigned-halfword :u16)
2848                 (:signed-fullword :s32)
2849                 (:unsigned-fullword :u32)
2850                 (:unsigned-doubleword :u64)
2851                 (:signed-doubleword :s64)))
2852         (modeval (gpr-mode-name-value mode)))
2853    (with-arm-local-vinsn-macros (seg)
2854      (let* ((value (arm2-integer-constant-p form mode)))
2855        (if value
2856            (progn
2857              (unless (typep immreg 'lreg)
2858                (setq immreg (make-unwired-lreg immreg :mode modeval)))
2859              (arm2-lri seg immreg value)
2860              immreg)
2861          (progn 
2862            (arm2-one-targeted-reg-form seg form (make-wired-lreg arm::imm0 :mode modeval))))))))
2863
2864
2865(defun arm2-macptr-arg-to-reg (seg form address-reg) 
2866  (arm2-one-targeted-reg-form seg
2867                              form 
2868                              address-reg))
2869
2870(defun arm2-push-reg-for-form (seg form suggested &optional targeted)
2871  (let* ((reg (if (and (node-reg-p suggested)
2872                         (nx2-acode-call-p form))     ;probably ...
2873                (arm2-one-targeted-reg-form seg form  arm::arg_z)
2874                (if targeted
2875                  (arm2-one-targeted-reg-form seg form suggested)
2876                  (arm2-one-untargeted-reg-form seg form suggested)))))
2877    (arm2-push-register seg reg)))
2878
2879(defun arm2-one-lreg-form (seg form lreg)
2880  (let ((is-float (= (hard-regspec-class lreg) hard-reg-class-fpr)))
2881    (if is-float
2882      (arm2-form-float seg lreg nil form)
2883      (arm2-form seg lreg nil form))
2884    lreg))
2885
2886(defun arm2-one-targeted-reg-form (seg form reg)
2887  (arm2-one-lreg-form seg form reg))
2888
2889(defun arm2-one-untargeted-lreg-form (seg form reg)
2890  (arm2-one-lreg-form seg form (if (typep reg 'lreg) reg (make-unwired-lreg reg))))
2891
2892(defun same-arm-reg-p (x y)
2893  (and (eq (hard-regspec-value x) (hard-regspec-value y))
2894       (let* ((class (hard-regspec-class x)))
2895         (and (eq class (hard-regspec-class y))
2896              (or (not (eql class hard-reg-class-fpr))
2897                  (eq (%get-regspec-mode x)
2898                      (%get-regspec-mode y)))))))
2899
2900;;; If REG is a node reg, add it to the bitmask.
2901(defun arm2-restrict-node-target (reg mask)
2902  (if (node-reg-p reg)
2903    (logior mask (ash 1 (hard-regspec-value reg)))
2904    mask))
2905
2906;;; If suggested reg is a node reg that contains a stack location,
2907;;; try to use some other node temp.
2908(defun arm2-try-non-conflicting-reg (suggested reserved)
2909  (let* ((mask *arm2-gpr-locations-valid-mask*))
2910    (or (when (and (node-reg-p suggested)
2911                   (logbitp (hard-regspec-value suggested) mask))
2912          (setq mask (logior mask reserved))
2913          (%available-node-temp (logand *available-backend-node-temps*
2914                                        (lognot mask))))
2915        suggested)))
2916
2917(defun arm2-one-untargeted-reg-form (seg form suggested &optional (reserved 0))
2918  (or (arm2-reg-for-form form suggested)
2919      (if (and (acode-p form)
2920               (eq (acode-operator form) (%nx1-operator %current-tcr)))
2921        arm::rcontext
2922        (if (node-reg-p suggested)
2923          (arm2-one-untargeted-lreg-form seg form (arm2-try-non-conflicting-reg suggested reserved))
2924          (arm2-one-untargeted-lreg-form seg form suggested)))))
2925             
2926
2927(defun arm2-push-register (seg areg)
2928  (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr))
2929         (a-double (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-double)))
2930         (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node)))
2931         vinsn)
2932    (with-arm-local-vinsn-macros (seg)
2933      (if a-node
2934        (setq vinsn (arm2-vpush-register seg areg :node-temp))
2935        (progn
2936          (setq vinsn
2937                (if a-float
2938                  (if a-double
2939                    (! temp-push-double-float areg)
2940                    (! temp-push-single-float areg))
2941                  (! temp-push-unboxed-word areg)))
2942          (arm2-open-undo $undostkblk)))
2943      vinsn)))
2944
2945(defun arm2-pop-register (seg areg)
2946  (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr))
2947         (a-double (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-double)))
2948         (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node)))
2949         vinsn)
2950    (with-arm-local-vinsn-macros (seg)
2951      (if a-node
2952        (setq vinsn (arm2-vpop-register seg areg))
2953        (progn
2954          (setq vinsn
2955                (if a-float
2956                  (if a-double
2957                    (! temp-pop-double-float areg)
2958                    (! temp-pop-single-float areg))
2959                  (! temp-pop-unboxed-word areg)))
2960          (arm2-close-undo)))
2961      vinsn)))
2962
2963(defun arm2-acc-reg-for (reg)
2964  (with-arm-local-vinsn-macros (seg)
2965    (if (and (eql (hard-regspec-class reg) hard-reg-class-gpr)
2966             (eql (get-regspec-mode reg) hard-reg-class-gpr-mode-node))
2967      ($ arm::arg_z)
2968      reg)))
2969
2970;;; The compiler often generates superfluous pushes & pops.  Try to
2971;;; eliminate them.
2972;;; It's easier to elide pushes and pops to the SP.
2973(defun arm2-elide-pushes (seg push-vinsn pop-vinsn)
2974  (with-arm-local-vinsn-macros (seg)
2975    (let* ((pushed-reg (svref (vinsn-variable-parts push-vinsn) 0))
2976           (popped-reg (svref (vinsn-variable-parts pop-vinsn) 0))
2977           (same-reg (eq (hard-regspec-value pushed-reg)
2978                         (hard-regspec-value popped-reg)))
2979           (sp-p (vinsn-attribute-p push-vinsn :csp)))
2980      (when sp-p               ; vsp case is harder.
2981        (unless (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :csp :discard)
2982          (let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p
2983                                     push-vinsn pop-vinsn pushed-reg))
2984                 (popped-reg-is-set (if same-reg
2985                                      pushed-reg-is-set
2986                                      (vinsn-sequence-sets-reg-p
2987                                       push-vinsn pop-vinsn popped-reg))))
2988            (cond
2989              ((not (and pushed-reg-is-set popped-reg-is-set))
2990               (unless same-reg
2991                 (let* ((copy (if (eq (hard-regspec-class pushed-reg)
2992                                      hard-reg-class-fpr)
2993                                (if (eql (get-regspec-mode pushed-reg)
2994                                         hard-reg-class-fpr-mode-single)
2995                                  (! single-to-single popped-reg pushed-reg)
2996                                  (! double-to-double popped-reg pushed-reg))
2997                                (! copy-gpr popped-reg pushed-reg))))
2998                   (remove-dll-node copy)
2999                   (if pushed-reg-is-set
3000                     (insert-dll-node-after copy push-vinsn)
3001                     (insert-dll-node-before copy push-vinsn))))
3002               (elide-vinsn push-vinsn)
3003               (elide-vinsn pop-vinsn))
3004              ((and (eql (hard-regspec-class pushed-reg) hard-reg-class-fpr)
3005                    (eql (get-regspec-mode pushed-reg)
3006                         hard-reg-class-fpr-mode-double))
3007               ;; If we're pushing a double-float register that gets
3008               ;; set by the intervening vinsns, try to copy it to and
3009               ;; from a free FPR instead.
3010               (multiple-value-bind (used-gprs used-fprs)
3011                   (regs-set-in-vinsn-sequence push-vinsn pop-vinsn)
3012                 (declare (ignore used-gprs))
3013                 ;; We have 16 non-volatile single-floats or 8
3014                 ;; non-volatile double-floats
3015                 (let* ((nfprs 7)
3016                        (free-fpr
3017                         (dotimes (r nfprs nil)
3018                           (unless (logtest (target-fpr-mask r :double-float)
3019                                            used-fprs)
3020                             (return r)))))
3021                   (when free-fpr
3022                     (let* ((reg ($ free-fpr :class :fpr :mode :double-float))
3023                            (save (! double-to-double reg pushed-reg))
3024                            (restore (! double-to-double popped-reg reg)))
3025                       (remove-dll-node save)
3026                       (insert-dll-node-after save push-vinsn)
3027                       (remove-dll-node restore)
3028                       (insert-dll-node-before restore pop-vinsn)
3029                       (elide-vinsn push-vinsn)
3030                       (elide-vinsn pop-vinsn))))))))))
3031      (when (and (vinsn-attribute-p push-vinsn :vsp))
3032        (unless (or
3033                 (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :vsp :push)
3034                 (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :vsp :pop)
3035                 (let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p
3036                                            push-vinsn pop-vinsn pushed-reg))
3037                        (popped-reg-is-set (if same-reg
3038                                             pushed-reg-is-set
3039                                             (vinsn-sequence-sets-reg-p
3040                                              push-vinsn pop-vinsn popped-reg)))
3041                        (popped-reg-is-reffed (unless same-reg
3042                                                (vinsn-sequence-refs-reg-p
3043                                                 push-vinsn pop-vinsn popped-reg))))
3044                   (cond ((and (not (and pushed-reg-is-set popped-reg-is-set))
3045                               (or (null popped-reg-is-reffed)
3046                                   (null pushed-reg-is-set)
3047                                   ;; If the popped register is
3048                                   ;; referenced and the pushed
3049                                   ;; register is set, we want to be
3050                                   ;; sure that the last reference
3051                                   ;; happens before the first
3052                                   ;; assignent.  We can't be sure
3053                                   ;; that either of these things
3054                                   ;; actually happened or happen
3055                                   ;; unconditionally, and can't
3056                                   ;; be sure of the order in which
3057                                   ;; they might happen if the sequence
3058                                   ;; contains jumps or branches.
3059                                   (vinsn-in-sequence-p pushed-reg-is-set popped-reg-is-reffed pop-vinsn)
3060                                   (not (vinsn-sequence-has-some-attribute-p push-vinsn pop-vinsn :branch :jump))))
3061                          ;; We don't try this if anything's pushed on
3062                          ;; or popped from the vstack in the
3063                          ;; sequence, but there can be references to
3064                          ;; other things that were pushed earlier.
3065                          ;; Those references use the vstack depth at
3066                          ;; the time of the reference and the
3067                          ;; canonical frame offset to address
3068                          ;; relative to the vsp.  If we elide the
3069                          ;; push, the vstack depth will be 4 bytes
3070                          ;; less than when the reference was
3071                          ;; generated.  Fix that up ...  There was
3072                          ;; (once) a notion of modeling the vstack as
3073                          ;; a list of "lcells"; lcells had a width
3074                          ;; attribute that was usually the native
3075                          ;; word size.  Eliding a push involved
3076                          ;; setting the width of the lcell
3077                          ;; representing the pushed word to 0.
3078                          ;; That whole idea was never fully implemented,
3079                          ;; though we generally try to maintain the model.
3080                          ;; If it ever is implemented, we need to dtrt
3081                          ;; here.
3082                          (do* ((element (dll-node-succ push-vinsn) (dll-node-succ element)))
3083                               ((eq element pop-vinsn))
3084                            (when (typep element 'vinsn)
3085                              (let* ((template (vinsn-template element))
3086                                     (opidx (case (vinsn-template-name template)
3087                                              (vframe-store 2)
3088                                              (vframe-load 2))))
3089                                (when opidx
3090                                  (let* ((operands (vinsn-variable-parts element)))
3091                                    (declare (simple-vector operands))
3092                                    (setf (svref operands opidx)
3093                                          (the fixnum
3094                                            (- (the fixnum (svref operands opidx))
3095                                               arm::node-size))))))))
3096                          (unless same-reg
3097                            (let* ((copy (! copy-gpr popped-reg pushed-reg)))
3098                              (remove-dll-node copy)
3099                              (if pushed-reg-is-set
3100                                  (insert-dll-node-after copy push-vinsn)
3101                                  (insert-dll-node-before copy pop-vinsn))))
3102                          (elide-vinsn push-vinsn)
3103                          (elide-vinsn pop-vinsn))
3104                   (t                   ; maybe allocate a node temp
3105                    )))))))))
3106               
3107       
3108;;; we never leave the first form pushed (the 68K compiler had some subprims that
3109;;; would vpop the first argument out of line.)
3110(defun arm2-two-targeted-reg-forms (seg aform areg bform breg)
3111  (let* ((avar (arm2-lexical-reference-p aform))
3112         (atriv (and (arm2-trivial-p bform) (nx2-node-gpr-p breg)))
3113         (aconst (and (not atriv) (or (arm-side-effect-free-form-p aform)
3114                                      (if avar (arm2-var-not-set-by-form-p avar bform)))))
3115         (apushed))
3116    (progn
3117      (unless aconst
3118        (if atriv
3119          (arm2-one-targeted-reg-form seg aform areg)
3120          (setq apushed (arm2-push-reg-for-form seg aform areg t))))
3121      (arm2-one-targeted-reg-form seg bform breg)
3122      (if aconst
3123        (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)
3124               (*available-backend-node-temps* *available-backend-node-temps*)
3125               (*available-backend-fp-temps* *available-backend-fp-temps*)
3126               (bclass (hard-regspec-class breg))
3127               (bregval (hard-regspec-value breg)))
3128          (if (eq bclass hard-reg-class-fpr)
3129            (use-fp-reg breg)
3130            (if (eq bclass hard-reg-class-gpr)
3131              (if (eq (get-regspec-mode breg) hard-reg-class-gpr-mode-node)
3132                (use-node-temp bregval)
3133                (use-imm-temp bregval))))
3134          (arm2-one-targeted-reg-form seg aform areg))
3135        (if apushed
3136          (arm2-elide-pushes seg apushed (arm2-pop-register seg areg)))))
3137    (values areg breg)))
3138
3139
3140(defun arm2-two-untargeted-reg-forms (seg aform areg bform breg)
3141  (let* ((aalready (arm2-reg-for-form aform areg))
3142         (balready (arm2-reg-for-form bform breg)))
3143    (if (and aalready balready)
3144      (values aalready balready)
3145      (with-arm-local-vinsn-macros (seg)
3146        (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)
3147               (avar (arm2-lexical-reference-p aform))
3148               (adest nil)
3149               (bdest nil)
3150               (atriv (and (arm2-trivial-p bform) (nx2-node-gpr-p breg)))
3151               (aconst (and (not atriv) (or (arm-side-effect-free-form-p aform)
3152                                            (if avar (arm2-var-not-set-by-form-p avar bform)))))
3153               (apushed nil)
3154               (restricted 0))
3155          (progn
3156            (unless aconst
3157              (if atriv
3158                (progn
3159                  (setq adest (arm2-one-untargeted-reg-form seg aform areg)
3160                        restricted (arm2-restrict-node-target adest 0))
3161                  (when (imm-reg-p adest)
3162                    (use-imm-temp (%hard-regspec-value adest)))
3163                  (when (same-arm-reg-p adest breg)
3164                    (setq breg areg)))
3165                (setq apushed (arm2-push-reg-for-form seg aform areg))))
3166            (setq bdest (arm2-one-untargeted-reg-form seg bform breg restricted)
3167                  restricted (arm2-restrict-node-target bdest restricted))
3168            (unless adest
3169              (if (same-arm-reg-p areg bdest)
3170                (setq areg breg)))
3171            (if aconst
3172              (progn
3173                (if (imm-reg-p bdest)
3174                  (use-imm-temp (%hard-regspec-value bdest)))
3175                (setq adest (arm2-one-untargeted-reg-form seg aform areg restricted)))
3176              (if apushed
3177                (arm2-elide-pushes seg apushed (arm2-pop-register seg (setq adest areg))))))
3178          (values adest bdest))))))
3179
3180
3181(defun arm2-four-targeted-reg-forms (seg aform areg bform breg cform creg dform dreg)
3182  (let* ((bnode (nx2-node-gpr-p breg))
3183         (cnode (nx2-node-gpr-p creg))
3184         (dnode (nx2-node-gpr-p dreg))
3185         (atriv (or (null aform) 
3186                    (and (arm2-trivial-p bform)
3187                         (arm2-trivial-p cform)
3188                         (arm2-trivial-p dform)
3189                         bnode
3190                         cnode
3191                         dnode)))
3192         (btriv (or (null bform)
3193                    (and (arm2-trivial-p cform)
3194                         (arm2-trivial-p dform)
3195                         cnode
3196                         dnode)))
3197         (ctriv (or (null cform)
3198                    (and (arm2-trivial-p dform) dnode)))
3199         
3200         (aconst (and (not atriv) 
3201                      (or (arm-side-effect-free-form-p aform)
3202                          (let ((avar (arm2-lexical-reference-p aform)))
3203                            (and avar 
3204                                 (arm2-var-not-set-by-form-p avar bform)
3205                                 (arm2-var-not-set-by-form-p avar cform)
3206                                 (arm2-var-not-set-by-form-p avar dform))))))
3207         (bconst (and (not btriv)
3208                      (or (arm-side-effect-free-form-p bform)
3209                          (let ((bvar (arm2-lexical-reference-p bform)))
3210                            (and bvar
3211                                 (arm2-var-not-set-by-form-p bvar cform)
3212                                 (arm2-var-not-set-by-form-p bvar dform))))))
3213         (cconst (and (not ctriv)
3214                      (or (arm-side-effect-free-form-p cform)
3215                          (let ((cvar (arm2-lexical-reference-p cform)))
3216                            (and cvar
3217                                 (arm2-var-not-set-by-form-p cvar dform))))))
3218         (apushed nil)
3219         (bpushed nil)
3220         (cpushed nil))
3221    (if (and aform (not aconst))
3222      (if atriv
3223        (arm2-one-targeted-reg-form seg aform areg)
3224        (setq apushed (arm2-push-reg-for-form seg aform areg t))))
3225    (if (and bform (not bconst))
3226      (if btriv
3227        (arm2-one-targeted-reg-form seg bform breg)
3228        (setq bpushed (arm2-push-reg-for-form seg bform breg t))))
3229    (if (and cform (not cconst))
3230      (if ctriv
3231        (arm2-one-targeted-reg-form seg cform creg)
3232        (setq cpushed (arm2-push-reg-for-form seg cform creg t))))
3233    (arm2-one-targeted-reg-form seg dform dreg)
3234    (unless ctriv
3235      (if cconst
3236        (arm2-one-targeted-reg-form seg cform creg)
3237        (arm2-elide-pushes seg cpushed (arm2-pop-register seg creg))))
3238    (unless btriv 
3239      (if bconst
3240        (arm2-one-targeted-reg-form seg bform breg)
3241        (arm2-elide-pushes seg bpushed (arm2-pop-register seg breg))))
3242    (unless atriv
3243      (if aconst
3244        (arm2-one-targeted-reg-form seg aform areg)
3245        (arm2-elide-pushes seg apushed (arm2-pop-register seg areg))))
3246    (values areg breg creg dreg)))
3247
3248(defun arm2-three-targeted-reg-forms (seg aform areg bform breg cform creg)
3249  (let* ((bnode (nx2-node-gpr-p breg))
3250         (cnode (nx2-node-gpr-p creg))
3251         (atriv (or (null aform) 
3252                    (and (arm2-trivial-p bform)
3253                         (arm2-trivial-p cform)
3254                         bnode
3255                         cnode)))
3256         (btriv (or (null bform)
3257                    (and (arm2-trivial-p cform)
3258                         cnode)))
3259         (aconst (and (not atriv) 
3260                      (or (arm-side-effect-free-form-p aform)
3261                          (let ((avar (arm2-lexical-reference-p aform)))
3262                            (and avar 
3263                                 (arm2-var-not-set-by-form-p avar bform)
3264                                 (arm2-var-not-set-by-form-p avar cform))))))
3265         (bconst (and (not btriv)
3266                      (or
3267                       (arm-side-effect-free-form-p bform)
3268                       (let ((bvar (arm2-lexical-reference-p bform)))
3269                         (and bvar (arm2-var-not-set-by-form-p bvar cform))))))
3270         (apushed nil)
3271         (bpushed nil))
3272    (if (and aform (not aconst))
3273      (if atriv
3274        (arm2-one-targeted-reg-form seg aform areg)
3275        (setq apushed (arm2-push-reg-for-form seg aform areg t))))
3276    (if (and bform (not bconst))
3277      (if btriv
3278        (arm2-one-targeted-reg-form seg bform breg)
3279        (setq bpushed (arm2-push-reg-for-form seg bform breg t))))
3280    (arm2-one-targeted-reg-form seg cform creg)
3281    (unless btriv 
3282      (if bconst
3283        (arm2-one-targeted-reg-form seg bform breg)
3284        (arm2-elide-pushes seg bpushed (arm2-pop-register seg breg))))
3285    (unless atriv
3286      (if aconst
3287        (arm2-one-targeted-reg-form seg aform areg)
3288        (arm2-elide-pushes seg apushed (arm2-pop-register seg areg))))
3289    (values areg breg creg)))
3290
3291(defun arm2-three-untargeted-reg-forms (seg aform areg bform breg cform creg)
3292  (with-arm-local-vinsn-macros (seg)
3293    (let* ((bnode (nx2-node-gpr-p breg))
3294           (cnode (nx2-node-gpr-p creg))
3295           (atriv (or (null aform) 
3296                      (and (arm2-trivial-p bform)
3297                           (arm2-trivial-p cform)
3298                           bnode
3299                           cnode)))
3300           (btriv (or (null bform)
3301                      (and (arm2-trivial-p cform)
3302                           cnode)))
3303           (aconst (and (not atriv) 
3304                        (or (arm-side-effect-free-form-p aform)
3305                            (let ((avar (arm2-lexical-reference-p aform)))
3306                              (and avar 
3307                                   (arm2-var-not-set-by-form-p avar bform)
3308                                   (arm2-var-not-set-by-form-p avar cform))))))
3309           (bconst (and (not btriv)
3310                        (or
3311                         (arm-side-effect-free-form-p bform)
3312                         (let ((bvar (arm2-lexical-reference-p bform)))
3313                           (and bvar (arm2-var-not-set-by-form-p bvar cform))))))
3314           (adest nil)
3315           (bdest nil)
3316           (cdest nil)
3317           (apushed nil)
3318           (bpushed nil)
3319           (restricted 0))
3320      (when (and aform (not aconst))
3321        (if atriv
3322          (progn
3323            (setq adest (arm2-one-untargeted-reg-form seg aform ($ areg))
3324                  restricted (arm2-restrict-node-target adest 0))
3325            (when (same-arm-reg-p adest breg)
3326              (setq breg areg))
3327            (when (same-arm-reg-p adest creg)
3328              (setq creg areg)))
3329          (setq apushed (arm2-push-reg-for-form seg aform areg ))))
3330      (when (and bform (not bconst))
3331        (if btriv
3332          (progn
3333            (setq bdest (arm2-one-untargeted-reg-form seg bform ($ breg) restricted)
3334                  restricted (arm2-restrict-node-target bdest restricted))
3335            (when (same-arm-reg-p bdest creg)
3336              (setq creg breg))
3337            (when (same-arm-reg-p bdest areg)
3338              (setq areg breg)))
3339          (setq bpushed (arm2-push-reg-for-form seg bform breg))))
3340      (setq cdest (arm2-one-untargeted-reg-form seg cform creg restricted)
3341            restricted (arm2-restrict-node-target cdest restricted))
3342      (when (same-arm-reg-p cdest areg)
3343        (setq areg creg))
3344      (when (same-arm-reg-p cdest breg)
3345        (setq breg creg))
3346      (unless btriv 
3347        (if bconst
3348          (setq bdest (arm2-one-untargeted-reg-form seg bform breg restricted))
3349          (arm2-elide-pushes seg bpushed (arm2-pop-register seg (setq bdest breg))))
3350        (setq restricted (arm2-restrict-node-target bdest restricted))
3351        (when (same-arm-reg-p bdest areg)
3352          (setq areg breg)))
3353      (unless atriv
3354        (if aconst
3355          (setq adest (arm2-one-untargeted-reg-form seg aform areg restricted))
3356          (arm2-elide-pushes seg apushed (arm2-pop-register seg (setq adest areg)))))
3357      (values adest bdest cdest))))
3358
3359(defun arm2-four-untargeted-reg-forms (seg aform areg bform breg cform creg dform dreg)
3360  (let* ((bnode (nx2-node-gpr-p breg))
3361         (cnode (nx2-node-gpr-p creg))
3362         (dnode (nx2-node-gpr-p dreg))
3363         (atriv (or (null aform) 
3364                    (and (arm2-trivial-p bform)
3365                         (arm2-trivial-p cform)
3366                         (arm2-trivial-p dform)
3367                         bnode
3368                         cnode
3369                         dnode)))
3370         (btriv (or (null bform)
3371                    (and (arm2-trivial-p cform)
3372                         (arm2-trivial-p dform)
3373                         cnode
3374                         dnode)))
3375         (ctriv (or (null cform)
3376                    (and (arm2-trivial-p dform) dnode)))
3377         (aconst (and (not atriv) 
3378                      (or (arm-side-effect-free-form-p aform)
3379                          (let ((avar (arm2-lexical-reference-p aform)))
3380                            (and avar 
3381                                 (arm2-var-not-set-by-form-p avar bform)
3382                                 (arm2-var-not-set-by-form-p avar cform)
3383                                 (arm2-var-not-set-by-form-p avar dform))))))
3384         (bconst (and (not btriv)
3385                      (or
3386                       (arm-side-effect-free-form-p bform)
3387                       (let ((bvar (arm2-lexical-reference-p bform)))
3388                         (and bvar
3389                              (arm2-var-not-set-by-form-p bvar cform)
3390                              (arm2-var-not-set-by-form-p bvar dform))))))
3391         (cconst (and (not ctriv)
3392                      (or
3393                       (arm-side-effect-free-form-p cform)
3394                       (let ((cvar (arm2-lexical-reference-p cform)))
3395                         (and cvar
3396                              (arm2-var-not-set-by-form-p cvar dform))))))
3397         (adest nil)
3398         (bdest nil)
3399         (cdest nil)
3400         (ddest nil)
3401         (apushed nil)
3402         (bpushed nil)
3403         (cpushed nil)
3404         (restricted 0))
3405    (if (and aform (not aconst))
3406      (if atriv
3407        (progn
3408          (setq adest (arm2-one-untargeted-reg-form seg aform areg)
3409                restricted (arm2-restrict-node-target adest restricted))
3410          (when (same-arm-reg-p adest breg)
3411            (setq breg areg))
3412          (when (same-arm-reg-p adest creg)
3413            (setq creg areg))
3414          (when (same-arm-reg-p adest dreg)
3415            (setq dreg areg)))
3416        (setq apushed (arm2-push-reg-for-form seg aform areg))))
3417    (if (and bform (not bconst))
3418      (if btriv
3419        (progn
3420          (setq bdest (arm2-one-untargeted-reg-form seg bform breg restricted)
3421                restricted (arm2-restrict-node-target bdest restricted))
3422          (unless adest
3423            (when (same-arm-reg-p areg bdest)
3424              (setq areg breg)))
3425          (when (same-arm-reg-p bdest creg)
3426            (setq creg breg))
3427          (when (same-arm-reg-p bdest dreg)
3428            (setq dreg breg)))
3429        (setq bpushed (arm2-push-reg-for-form seg bform breg))))
3430    (if (and cform (not cconst))
3431      (if ctriv
3432        (progn
3433          (setq cdest (arm2-one-untargeted-reg-form seg cform creg restricted)
3434                restricted (arm2-restrict-node-target cdest restricted))
3435          (unless adest
3436            (when (same-arm-reg-p areg cdest)
3437              (setq areg creg)))
3438          (unless bdest
3439            (when (same-arm-reg-p breg cdest)
3440              (setq breg creg)))         
3441          (when (same-arm-reg-p cdest dreg)
3442            (setq dreg creg)))
3443        (setq cpushed (arm2-push-reg-for-form seg cform creg))))
3444    (setq ddest (arm2-one-untargeted-reg-form seg dform dreg restricted)
3445          restricted (arm2-restrict-node-target ddest restricted))
3446    (unless adest
3447      (when (same-arm-reg-p ddest areg)
3448        (setq areg dreg)))
3449    (unless bdest
3450      (when (same-arm-reg-p ddest breg)
3451        (setq breg dreg)))
3452    (unless cdest
3453      (when (same-arm-reg-p ddest creg)
3454        (setq creg dreg)))
3455    (unless ctriv 
3456      (if cconst
3457        (setq cdest (arm2-one-untargeted-reg-form seg cform creg restricted))
3458        (arm2-elide-pushes seg cpushed (arm2-pop-register seg (setq cdest creg))))
3459      (setq restricted (arm2-restrict-node-target cdest restricted))
3460      (unless adest
3461        (when (same-arm-reg-p cdest areg)
3462          (setq areg creg)))
3463      (unless bdest
3464        (when (same-arm-reg-p ddest breg)
3465          (setq breg creg))))
3466    (unless btriv 
3467      (if bconst
3468        (setq bdest (arm2-one-untargeted-reg-form seg bform breg restricted))
3469        (arm2-elide-pushes seg bpushed (arm2-pop-register seg (setq bdest breg))))
3470      (setq restricted (arm2-restrict-node-target bdest restricted))
3471      (unless adest
3472        (when (same-arm-reg-p bdest areg)
3473          (setq areg breg))))
3474    (unless atriv
3475      (if aconst
3476        (setq adest (arm2-one-untargeted-reg-form seg aform areg restricted))
3477        (arm2-elide-pushes seg apushed (arm2-pop-register seg (setq adest areg)))))
3478    (values adest bdest cdest ddest)))
3479
3480(defun arm2-lri (seg reg value)
3481  (with-arm-local-vinsn-macros (seg)
3482    (if (>= value 0)
3483      (! lri reg value)
3484      (! lri reg (logand value #xffffffff)))))
3485
3486
3487(defun arm2-multiple-value-body (seg form)
3488  (let* ((lab (backend-get-next-label))
3489         (*arm2-vstack* *arm2-vstack*)
3490         (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*)
3491         (old-stack (arm2-encode-stack)))
3492    (with-arm-local-vinsn-macros (seg)
3493      (arm2-open-undo $undomvexpect)
3494      (arm2-undo-body seg nil (logior $backend-mvpass-mask lab) form old-stack)
3495      (@ lab))))
3496
3497(defun arm2-afunc-lfun-ref (afunc)
3498  (or
3499   (afunc-lfun afunc)
3500   (progn (pushnew afunc (afunc-fwd-refs *arm2-cur-afunc*) :test #'eq)
3501          afunc)))
3502
3503(defun arm2-augment-arglist (afunc arglist &optional (maxregs $numarmargregs))
3504  (let ((inherited-args (afunc-inherited-vars afunc)))
3505    (when inherited-args
3506      (let* ((current-afunc *arm2-cur-afunc*)
3507             (stkargs (car arglist))
3508             (regargs (cadr arglist))
3509             (inhforms nil)
3510             (numregs (length regargs))
3511             (own-inhvars (afunc-inherited-vars current-afunc)))
3512        (dolist (var inherited-args)
3513          (let* ((root-var (nx-root-var var))
3514                 (other-guy 
3515                  (dolist (v own-inhvars #|(compiler-bug "other guy not found")|# root-var)
3516                    (when (eq root-var (nx-root-var v)) (return v)))))
3517            (push (make-acode (%nx1-operator inherited-arg) other-guy) inhforms)))
3518        (dolist (form inhforms)
3519          (if (%i< numregs maxregs)
3520            (progn
3521              (setq regargs (nconc regargs (list form)))
3522              (setq numregs (%i+ numregs 1)))
3523            (push form stkargs)))
3524        (%rplaca (%cdr arglist) regargs) ; might have started out NIL.
3525        (%rplaca arglist stkargs)))) 
3526  arglist)
3527
3528(defun arm2-constant-for-compare-p (form &optional unboxed)
3529  (setq form (acode-unwrapped-form form))
3530  (when (acode-p form)
3531    (let* ((op (acode-operator form)))
3532      (if (eql op (%nx1-operator fixnum))
3533        (let* ((val (if unboxed
3534                      (cadr form)
3535                      (ash (cadr form) arm::fixnumshift))))
3536          (if (or (arm::encode-arm-immediate val)
3537                  (arm::encode-arm-immediate (- val)))
3538            (logand val #xffffffff)))
3539        (if (eql op (%nx1-operator %unbound-marker))
3540          arm::unbound-marker
3541          (if (eql op (%nx1-operator %slot-unbound-marker))
3542            arm::slot-unbound-marker))))))
3543
3544(defun arm2-acode-operator-supports-u8 (form)
3545  (setq form (acode-unwrapped-form-value form))
3546  (when (acode-p form)
3547    (let* ((operator (acode-operator form)))
3548      (if (member operator *arm2-operator-supports-u8-target*)
3549        (values operator (acode-operand 1 form))))))
3550
3551(defun arm2-compare-u8 (seg vreg xfer form u8constant cr-bit true-p u8-operator)
3552  (with-arm-local-vinsn-macros (seg vreg xfer)
3553    (with-imm-target () (u8 :u8)
3554      (with-crf-target () crf
3555        (if (and (eql u8-operator (%nx1-operator lisptag))
3556                 (eql 0 u8constant)
3557                 (eql cr-bit arm::arm-cond-eq))
3558          (let* ((formreg (arm2-one-untargeted-reg-form seg form arm::arg_z)))
3559            (! test-fixnum crf formreg))
3560          (progn
3561           (arm2-use-operator u8-operator seg u8 nil form)
3562           (! compare-immediate crf u8 u8constant))))
3563      ;; Flags set.  Branch or return a boolean value ?
3564      (regspec-crf-gpr-case 
3565       (vreg dest)
3566       (^ cr-bit true-p)
3567       (progn
3568         (ensuring-node-target (target dest)
3569           (if (not true-p)
3570             (setq cr-bit (logxor 1 cr-bit)))
3571           (! cond->boolean target cr-bit))
3572         (^))))))
3573
3574;;; There are other cases involving constants that are worth exploiting.
3575(defun arm2-compare (seg vreg xfer i j cr-bit true-p)
3576  (with-arm-local-vinsn-macros (seg vreg xfer)
3577    (let* ((iu8 (let* ((i-fixnum (acode-fixnum-form-p i)))
3578                  (if (typep i-fixnum '(unsigned-byte 8))
3579                    i-fixnum)))
3580           (ju8 (let* ((j-fixnum (acode-fixnum-form-p j)))
3581                  (if (typep j-fixnum '(unsigned-byte 8))
3582                    j-fixnum)))
3583           (u8 (or iu8 ju8))
3584           (other-u8 (if iu8 j (if ju8 i)))
3585           (jconst (arm2-constant-for-compare-p j))
3586           (iconst (arm2-constant-for-compare-p i))
3587           (boolean (backend-crf-p vreg)))
3588      (multiple-value-bind (u8-operator u8-operand) (if other-u8 (arm2-acode-operator-supports-u8 other-u8))
3589        (if u8-operator
3590          (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)
3591          (if (and boolean (or iconst jconst))
3592            (let* ((reg (arm2-one-untargeted-reg-form seg (if jconst i j) arm::arg_z)))
3593              (! compare-immediate vreg reg (or jconst iconst))
3594              (unless (or jconst (eq cr-bit arm::arm-cond-eq))
3595                (setq cr-bit (arm2-cr-bit-for-reversed-comparison cr-bit)))
3596              (^ cr-bit true-p))
3597            (if (and (eq cr-bit arm::arm-cond-eq) 
3598                     (or jconst iconst))
3599              (arm2-test-reg-%izerop 
3600               seg 
3601               vreg 
3602               xfer 
3603               (arm2-one-untargeted-reg-form 
3604                seg 
3605                (if jconst i j) 
3606                arm::arg_z) 
3607               cr-bit 
3608               true-p 
3609               (or jconst iconst))
3610              (multiple-value-bind (ireg jreg) (arm2-two-untargeted-reg-forms seg i arm::arg_y j arm::arg_z)
3611                (arm2-compare-registers seg vreg xfer ireg jreg cr-bit true-p)))))))))
3612
3613(defun arm2-natural-compare (seg vreg xfer i j cr-bit true-p)
3614  (with-arm-local-vinsn-macros (seg vreg xfer)
3615    (let* ((jconst (arm2-constant-for-compare-p j t))
3616           (iconst (arm2-constant-for-compare-p i t))
3617           (boolean (backend-crf-p vreg)))
3618          (if (and boolean (or iconst jconst))
3619            (let* ((reg (arm2-one-untargeted-reg-form seg (if jconst i j) ($ arm::imm0 :mode :u32))))
3620              (! compare-immediate vreg reg (or jconst iconst))
3621              (unless (or jconst (eq cr-bit arm::arm-cond-eq))
3622                (setq cr-bit (arm2-cr-bit-for-reversed-comparison cr-bit)))
3623              (^ cr-bit true-p))
3624            (if (and (eq cr-bit arm::arm-cond-eq) 
3625                     (or jconst iconst))
3626              (arm2-test-reg-%izerop 
3627               seg 
3628               vreg 
3629               xfer 
3630               (arm2-one-untargeted-reg-form 
3631                seg 
3632                (if jconst i j) 
3633                ($ arm::imm0 :mode :u32))
3634               cr-bit 
3635               true-p 
3636               (or jconst iconst))
3637              (multiple-value-bind (ireg jreg) (arm2-two-untargeted-reg-forms seg i ($ arm::imm0 :mode :u32)  j ($ arm::imm1 :mode :u32))
3638                (arm2-compare-registers seg vreg xfer ireg jreg cr-bit true-p)))))))
3639
3640
3641
3642(defun arm2-compare-registers (seg vreg xfer ireg jreg cr-bit true-p)
3643  (with-arm-local-vinsn-macros (seg vreg xfer)
3644    (if vreg
3645      (regspec-crf-gpr-case 
3646       (vreg dest)
3647       (progn
3648         (! compare dest ireg jreg)
3649         (^ cr-bit true-p))
3650       (with-crf-target () crf
3651         (! compare crf ireg jreg)
3652         (ensuring-node-target (target vreg)
3653           (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))))
3654         (^)))
3655      (^))))
3656
3657(defun arm2-compare-register-to-nil (seg vreg xfer ireg cr-bit true-p)
3658  (with-arm-local-vinsn-macros (seg vreg xfer)
3659    (if vreg
3660      (regspec-crf-gpr-case 
3661       (vreg dest)
3662       (progn
3663         (! compare-to-nil dest ireg)
3664         (^ cr-bit true-p))
3665       (with-crf-target () crf
3666         (! compare-to-nil crf ireg)
3667         (ensuring-node-target (target dest)
3668           (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))))
3669         (^)))
3670      (^))))
3671
3672(defun arm2-compare-double-float-registers (seg vreg xfer ireg jreg cr-bit true-p)
3673  (with-arm-local-vinsn-macros (seg vreg xfer)
3674    (if vreg
3675      (regspec-crf-gpr-case 
3676       (vreg dest)
3677       (progn
3678         (! double-float-compare dest ireg jreg)
3679         (^ cr-bit true-p))
3680       (progn
3681         (with-crf-target () flags
3682           (! double-float-compare flags ireg jreg)
3683
3684           (! cond->boolean dest (if true-p cr-bit (logxor cr-bit 1))))
3685         (^)))
3686      (^))))
3687
3688(defun arm2-compare-single-float-registers (seg vreg xfer ireg jreg cr-bit true-p)
3689  (with-arm-local-vinsn-macros (seg vreg xfer)
3690    (if vreg
3691      (regspec-crf-gpr-case 
3692       (vreg dest)
3693       (progn
3694         (! single-float-compare dest ireg jreg)
3695         (^ cr-bit true-p))
3696       (progn
3697         (with-crf-target () flags
3698           (! single-float-compare flags ireg jreg)
3699
3700           (! cond->boolean dest (if true-p cr-bit (logxor cr-bit 1))))
3701         (^)))
3702      (^))))
3703
3704
3705
3706
3707(defun arm2-immediate-form-p (form)
3708  (if (and (consp form)
3709           (or (eq (%car form) (%nx1-operator immediate))
3710               (eq (%car form) (%nx1-operator simple-function))))
3711    t))
3712
3713(defun arm2-test-%izerop (seg vreg xfer form cr-bit true-p)
3714  (arm2-test-reg-%izerop seg vreg xfer (arm2-one-untargeted-reg-form seg form arm::arg_z) cr-bit true-p 0))
3715
3716(defun arm2-test-reg-%izerop (seg vreg xfer reg cr-bit true-p  zero)
3717  (declare (fixnum reg))
3718  (with-arm-local-vinsn-macros (seg vreg xfer)
3719    (regspec-crf-gpr-case 
3720     (vreg dest)
3721     (progn
3722       (if (or (arm::encode-arm-immediate zero)
3723               (arm::encode-arm-immediate (- zero)))
3724         (! compare-immediate dest reg zero)
3725         (with-node-target (reg) other
3726           (arm2-lri seg other zero)
3727           (! compare dest reg other)))
3728       (^ cr-bit true-p))
3729     (with-crf-target () crf
3730       (if (or (arm::encode-arm-immediate zero)
3731               (arm::encode-arm-immediate (- zero)))
3732         (! compare-immediate crf reg (logand #xffffffff zero))
3733         (with-node-target (reg) other
3734           (arm2-lri seg other zero)
3735           (! compare crf reg other)))
3736       (ensuring-node-target (target dest)
3737         (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))))
3738       (^)))))
3739
3740(defun arm2-lexical-reference-ea (form &optional (no-closed-p t))
3741  (when (acode-p (setq form (acode-unwrapped-form-value form)))
3742    (if (eq (acode-operator form) (%nx1-operator lexical-reference))
3743      (let* ((addr (var-ea (%cadr form))))
3744        (if (typep addr 'lreg)
3745          addr
3746          (unless (and no-closed-p (addrspec-vcell-p addr ))
3747            addr))))))
3748
3749
3750(defun arm2-vpush-register (seg src &optional why info attr)
3751  (with-arm-local-vinsn-macros (seg)
3752    (prog1
3753      (! vpush-register src)
3754      (arm2-regmap-note-store src *arm2-vstack*)
3755      (arm2-new-vstack-lcell (or why :node) *arm2-target-lcell-size* (or attr 0) info)
3756      (arm2-adjust-vstack *arm2-target-node-size*))))
3757
3758(defun arm2-vpush-register-arg (seg src)
3759  (arm2-vpush-register seg src :outgoing-argument))
3760
3761
3762(defun arm2-vpop-register (seg dest)
3763  (with-arm-local-vinsn-macros (seg)
3764    (prog1
3765      (! vpop-register dest)
3766      (setq *arm2-top-vstack-lcell* (lcell-parent *arm2-top-vstack-lcell*))
3767      (arm2-adjust-vstack (- *arm2-target-node-size*)))))
3768
3769
3770
3771     
3772       
3773
3774 
3775     
3776     
3777(defun arm2-copy-register (seg dest src)
3778  (with-arm-local-vinsn-macros (seg)
3779    (when dest
3780      (let* ((dest-gpr (backend-ea-physical-reg dest hard-reg-class-gpr))
3781             (src-gpr (if src (backend-ea-physical-reg src hard-reg-class-gpr)))
3782             (dest-fpr (backend-ea-physical-reg dest hard-reg-class-fpr))
3783             (src-fpr (if src (backend-ea-physical-reg src hard-reg-class-fpr)))
3784             (src-mode (if src (get-regspec-mode src)))
3785             (dest-mode (get-regspec-mode dest))
3786             (dest-crf (backend-ea-physical-reg dest hard-reg-class-crf)))
3787        (if (null src)
3788          (if dest-gpr
3789            (! load-nil dest-gpr)
3790            (if dest-crf
3791              (! set-eq-bit dest-crf)))
3792          (if dest-crf
3793            ;; "Copying" a GPR to a CR field means comparing it to nil
3794            (if src-gpr
3795              (! compare-to-nil dest src)
3796              (! compare-to-nil dest arm::sp))
3797            (if (and dest-gpr src-gpr)
3798              (case dest-mode
3799                (#.hard-reg-class-gpr-mode-node ; boxed result.
3800                 (case src-mode
3801                   (#.hard-reg-class-gpr-mode-node
3802                    (unless (eql  dest-gpr src-gpr)
3803                      (! copy-gpr dest src)))
3804                   (#.hard-reg-class-gpr-mode-u32
3805                    (arm2-box-u32 seg dest src))
3806                   (#.hard-reg-class-gpr-mode-s32
3807                    (arm2-box-s32 seg dest src))
3808                   (#.hard-reg-class-gpr-mode-u16
3809                    (! u16->fixnum dest src))
3810                   (#.hard-reg-class-gpr-mode-s16
3811                    (! s16->fixnum dest src))
3812                   (#.hard-reg-class-gpr-mode-u8
3813                    (! u8->fixnum dest src))
3814                   (#.hard-reg-class-gpr-mode-s8
3815                    (! s8->fixnum dest src))
3816                   (#.hard-reg-class-gpr-mode-address
3817                    (! macptr->heap dest src))))
3818                ((#.hard-reg-class-gpr-mode-u32
3819                  #.hard-reg-class-gpr-mode-address)
3820                 (case src-mode
3821                   (#.hard-reg-class-gpr-mode-node
3822                    (let* ((src-type (get-node-regspec-type-modes src)))
3823                      (declare (fixnum src-type))
3824                      (case dest-mode
3825                        (#.hard-reg-class-gpr-mode-u32
3826                         (! unbox-u32 dest src))
3827                        (#.hard-reg-class-gpr-mode-address
3828                         (unless (or (logbitp #.hard-reg-class-gpr-mode-address src-type)
3829                                     *arm2-reckless*)
3830                           (! trap-unless-macptr src))
3831                         (! deref-macptr dest src)))))
3832                   ((#.hard-reg-class-gpr-mode-u32
3833                     #.hard-reg-class-gpr-mode-s32
3834                     #.hard-reg-class-gpr-mode-address)
3835                    (unless (eql  dest-gpr src-gpr)
3836                      (! copy-gpr dest src)))
3837                   ((#.hard-reg-class-gpr-mode-u16
3838                     #.hard-reg-class-gpr-mode-s16)
3839                    (! u16->u32 dest src))
3840                   ((#.hard-reg-class-gpr-mode-u8
3841                     #.hard-reg-class-gpr-mode-s8)
3842                    (! u8->u32 dest src))))
3843                (#.hard-reg-class-gpr-mode-s32
3844                 (case src-mode
3845                   (#.hard-reg-class-gpr-mode-node
3846                    (! unbox-s32 dest src))
3847                   ((#.hard-reg-class-gpr-mode-u32
3848                     #.hard-reg-class-gpr-mode-s32
3849                     #.hard-reg-class-gpr-mode-address)
3850                    (unless (eql  dest-gpr src-gpr)
3851                      (! copy-gpr dest src)))
3852                   (#.hard-reg-class-gpr-mode-u16
3853                    (! u16->u32 dest src))                 
3854                   (#.hard-reg-class-gpr-mode-s16
3855                    (! s16->s32 dest src))
3856                   (#.hard-reg-class-gpr-mode-u8
3857                    (! u8->u32 dest src))
3858                   (#.hard-reg-class-gpr-mode-s8
3859                    (! s8->s32 dest src))))
3860                (#.hard-reg-class-gpr-mode-u16
3861                 (case src-mode
3862                   (#.hard-reg-class-gpr-mode-node
3863                    (! unbox-u16 dest src))
3864                   ((#.hard-reg-class-gpr-mode-u8
3865                     #.hard-reg-class-gpr-mode-s8)
3866                    (! u8->u32 dest src))
3867                   (t
3868                    (unless (eql dest-gpr src-gpr)
3869                      (! copy-gpr dest src)))))
3870                (#.hard-reg-class-gpr-mode-s16
3871                 (case src-mode
3872                   (#.hard-reg-class-gpr-mode-node
3873                    (! unbox-s16 dest src))
3874                   (#.hard-reg-class-gpr-mode-s8
3875                    (! s8->s32 dest src))
3876                   (#.hard-reg-class-gpr-mode-u8
3877                    (! u8->u32 dest src))
3878                   (t
3879                    (unless (eql dest-gpr src-gpr)
3880                      (! copy-gpr dest src)))))
3881                (#.hard-reg-class-gpr-mode-u8
3882                 (case src-mode
3883                   (#.hard-reg-class-gpr-mode-node
3884                    (if *arm2-reckless*
3885                      (! %unbox-u8 dest src)
3886                      (! unbox-u8 dest src)))
3887                   (t
3888                    (unless (eql dest-gpr src-gpr)
3889                      (! copy-gpr dest src)))))
3890                (#.hard-reg-class-gpr-mode-s8
3891                 (case src-mode
3892                   (#.hard-reg-class-gpr-mode-node
3893                    (! unbox-s8 dest src))
3894                   (t
3895                    (unless (eql dest-gpr src-gpr)
3896                      (! copy-gpr dest src))))))
3897              (if src-gpr
3898                (if dest-fpr
3899                  (progn
3900                    (case src-mode
3901                      (#.hard-reg-class-gpr-mode-node
3902                       (case dest-mode
3903                         (#.hard-reg-class-fpr-mode-double
3904                          (unless (or (logbitp hard-reg-class-fpr-type-double 
3905                                               (get-node-regspec-type-modes src))
3906                                      *arm2-reckless*)
3907                            (! trap-unless-double-float src))
3908                          (! get-double dest src))
3909                         (#.hard-reg-class-fpr-mode-single
3910                          (unless *arm2-reckless*
3911                            (! trap-unless-single-float src))
3912                          (! get-single dest src)))))))
3913                (if dest-gpr
3914                  (case dest-mode
3915                    (#.hard-reg-class-gpr-mode-node
3916                     (if src-fpr
3917                       (case src-mode
3918                         (#.hard-reg-class-fpr-mode-double
3919                          (! double->heap dest src))
3920                         (#.hard-reg-class-fpr-mode-single
3921                          (! single->node dest src))))))
3922                  (if (and src-fpr dest-fpr)
3923                    (unless (eql dest-fpr src-fpr)
3924                      (case src-mode
3925                        (#.hard-reg-class-fpr-mode-single
3926                         (case dest-mode
3927                           (#.hard-reg-class-fpr-mode-single
3928                            (! single-to-single dest src))
3929                           (#.hard-reg-class-fpr-mode-double
3930                            (! single-to-double dest src))))
3931                        (#.hard-reg-class-fpr-mode-double
3932                         (case dest-mode
3933                           (#.hard-reg-class-fpr-mode-single
3934                            (if *arm2-float-safety*
3935                              (! double-to-single-safe dest src)
3936                              (! double-to-single dest src)))
3937                           (#.hard-reg-class-fpr-mode-double
3938                            (! double-to-double dest src))))))))))))))))
3939 
3940(defun arm2-unreachable-store (&optional vreg)
3941  ;; I don't think that anything needs to be done here,
3942  ;; but leave this guy around until we're sure.
3943  ;; (ARM2-VPUSH-REGISTER will always vpush something, even
3944  ;; if code to -load- that "something" never gets generated.
3945  ;; If I'm right about this, that means that the compile-time
3946  ;; stack-discipline problem that this is supposed to deal
3947  ;; with can't happen.)
3948  (declare (ignore vreg))
3949  nil)
3950
3951;;; bind vars to initforms, as per let*, &aux.
3952(defun arm2-seq-bind (seg vars initforms)
3953  (dolist (var vars)
3954    (arm2-seq-bind-var seg var (pop initforms))))
3955
3956(defun arm2-dynamic-extent-form (seg curstack val &aux (form val))
3957  (when (acode-p form)
3958    (with-note (form seg curstack) ; note this rebinds form/seg/curstack so can't setq
3959      (with-arm-local-vinsn-macros (seg)
3960        (let* ((op (acode-operator form)))
3961          (cond ((eq op (%nx1-operator list))
3962                 (let* ((*arm2-vstack* *arm2-vstack*)
3963                        (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*))
3964                   (arm2-set-nargs seg (arm2-formlist seg (%cadr form) nil))
3965                   (arm2-open-undo $undostkblk curstack)
3966                   (! stack-cons-list))
3967                 (setq val arm::arg_z))
3968                ((eq op (%nx1-operator list*))
3969                 (let* ((arglist (%cadr form)))                   
3970                   (let* ((*arm2-vstack* *arm2-vstack*)
3971                          (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*))
3972                     (arm2-arglist seg arglist))
3973                   (when (car arglist)
3974                     (arm2-set-nargs seg (length (%car arglist)))
3975                     (! stack-cons-list*)
3976                     (arm2-open-undo $undostkblk curstack))
3977                   (setq val arm::arg_z)))
3978                ((eq op (%nx1-operator multiple-value-list))
3979                 (arm2-multiple-value-body seg (%cadr form))
3980                 (arm2-open-undo $undostkblk curstack)
3981                 (! stack-cons-list)
3982                 (setq val arm::arg_z))
3983                ((eq op (%nx1-operator cons))
3984                 (let* ((y ($ arm::arg_y))
3985                        (z ($ arm::arg_z))
3986                        (result ($ arm::arg_z)))
3987                   (arm2-two-targeted-reg-forms seg (%cadr form) y (%caddr form) z)
3988                   (arm2-open-undo $undostkblk )
3989                   (! make-stack-cons result y z) 
3990                   (setq val result)))
3991                ((eq op (%nx1-operator %consmacptr%))
3992                 (with-imm-target () (address :address)
3993                   (arm2-one-targeted-reg-form seg form address)
3994                   (with-node-temps () (node)
3995                     (! macptr->stack node address)
3996                     (arm2-open-undo $undostkblk)
3997                     (setq val node))))
3998                ((eq op (%nx1-operator %new-ptr))
3999                 (let* ((clear-form (caddr form))
4000                        (cval (nx2-constant-form-value clear-form)))
4001                   (if cval
4002                       (progn 
4003                         (arm2-one-targeted-reg-form seg (%cadr form) ($ arm::arg_z))
4004                         (if (nx-null cval)
4005                             (! make-stack-block)
4006                             (! make-stack-block0)))
4007                       (with-crf-target () crf
4008                         (let ((stack-block-0-label (backend-get-next-label))
4009                               (done-label (backend-get-next-label))
4010                               (rval ($ arm::arg_z))
4011                               (rclear ($ arm::arg_y)))
4012                           (arm2-two-targeted-reg-forms seg (%cadr form) rval clear-form rclear)
4013                           (! compare-to-nil crf rclear)
4014                           (! cbranch-false (aref *backend-labels* stack-block-0-label) crf arm::arm-cond-eq)
4015                           (! make-stack-block)
4016                           (-> done-label)
4017                           (@ stack-block-0-label)
4018                           (! make-stack-block0)
4019                           (@ done-label)))))
4020                 (arm2-open-undo $undostkblk)
4021                 (setq val ($ arm::arg_z)))
4022                ((eq op (%nx1-operator make-list))
4023                 (arm2-two-targeted-reg-forms seg (%cadr form) ($ arm::arg_y) (%caddr form) ($ arm::arg_z))
4024                 (arm2-open-undo $undostkblk curstack)
4025                 (! make-stack-list)
4026                 (setq val arm::arg_z))       
4027                ((eq op (%nx1-operator vector))
4028                 (let* ((*arm2-vstack* *arm2-vstack*)
4029                        (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*))
4030                   (arm2-set-nargs seg (arm2-formlist seg (%cadr form) nil))
4031                   (! make-stack-vector))
4032                 (arm2-open-undo $undostkblk)
4033                 (setq val arm::arg_z))
4034                ((eq op (%nx1-operator %gvector))
4035                 (let* ((*arm2-vstack* *arm2-vstack*)
4036                        (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*)
4037                        (arglist (%cadr form)))
4038                   (arm2-set-nargs seg (arm2-formlist seg (append (car arglist) (reverse (cadr arglist))) nil))
4039                   (! make-stack-gvector))
4040                 (arm2-open-undo $undostkblk)
4041                 (setq val arm::arg_z)) 
4042                ((eq op (%nx1-operator closed-function)) 
4043                 (setq val (arm2-make-closure seg (cadr form) t))) ; can't error
4044                ((eq op (%nx1-operator %make-uvector))
4045                 (destructuring-bind (element-count subtag &optional (init 0 init-p)) (%cdr form)
4046                   (if init-p
4047                       (progn
4048                         (arm2-three-targeted-reg-forms seg element-count ($ arm::arg_x) subtag ($ arm::arg_y) init ($ arm::arg_z))
4049                         (! stack-misc-alloc-init))
4050                       (progn
4051                         (arm2-two-targeted-reg-forms seg element-count ($ arm::arg_y)  subtag ($ arm::arg_z))
4052                         (! stack-misc-alloc)))
4053                   (arm2-open-undo $undostkblk)
4054                   (setq val ($ arm::arg_z)))))))))
4055  val)
4056
4057(defun arm2-addrspec-to-reg (seg addrspec reg)
4058  (if (memory-spec-p addrspec)
4059    (arm2-stack-to-register seg addrspec reg)
4060    (arm2-copy-register seg reg addrspec)))
4061 
4062(defun arm2-seq-bind-var (seg var val) 
4063  (with-arm-local-vinsn-macros (seg)
4064    (let* ((sym (var-name var))
4065           (bits (nx-var-bits var))
4066           (closed-p (and (%ilogbitp $vbitclosed bits)
4067                          (%ilogbitp $vbitsetq bits)))
4068           (curstack (arm2-encode-stack))
4069           (make-vcell (and closed-p (eq bits (var-bits var))))
4070           (closed-downward (and closed-p (%ilogbitp $vbitcloseddownward bits))))
4071      (unless (fixnump val)
4072        (setq val (nx-untyped-form val))
4073        (when (and (%ilogbitp $vbitdynamicextent bits) (acode-p val))
4074          (setq val (arm2-dynamic-extent-form seg curstack val))))
4075      (if (%ilogbitp $vbitspecial bits)
4076        (progn
4077          (arm2-dbind seg val sym)
4078          (arm2-set-var-ea seg var (arm2-vloc-ea (- *arm2-vstack* *arm2-target-node-size*))))
4079        (let ((puntval nil))
4080          (flet ((arm2-puntable-binding-p (var initform)
4081                   ; The value returned is acode.
4082                   (let* ((bits (nx-var-bits var)))
4083                     (if (%ilogbitp $vbitpuntable bits)
4084                       initform))))
4085            (declare (inline arm2-puntable-binding-p))
4086            (if (and (not (arm2-load-ea-p val))
4087                     (setq puntval (arm2-puntable-binding-p var val)))
4088              (progn
4089                (nx-set-var-bits var (%ilogior (%ilsl $vbitpunted 1) bits))
4090                (let* ((type (var-inittype var)))
4091                  (if (and type (not (eq t type)))
4092                    (nx2-replace-var-refs var
4093                                          (make-acode (%nx1-operator typed-form)
4094                                                      type
4095                                                      puntval))
4096                    (nx2-replace-var-refs var puntval)))
4097                (arm2-set-var-ea seg var puntval))
4098              (progn
4099                (let* ((vloc *arm2-vstack*)
4100                       (reg (let* ((r (nx2-assign-register-var var)))
4101                              (if r (make-wired-lreg r :class (hard-regspec-class r) :mode (get-regspec-mode r))))))
4102                  (if (arm2-load-ea-p val)
4103                    (if reg
4104                      (arm2-addrspec-to-reg seg val reg)
4105                      (if (memory-spec-p val)
4106                        (with-node-temps () (temp)
4107                          (arm2-addrspec-to-reg seg val temp)
4108                          (arm2-vpush-register seg temp :node var bits))
4109                        (arm2-vpush-register seg val :node var bits)))
4110                    (if reg
4111                      (arm2-one-targeted-reg-form seg val reg)
4112                      (arm2-vpush-register seg (arm2-one-untargeted-reg-form seg val arm::arg_z) :node var bits)))
4113                  (arm2-set-var-ea seg var (or reg (arm2-vloc-ea vloc closed-p)))
4114                  (if reg
4115                    (arm2-note-var-cell var reg)
4116                    (arm2-note-top-cell var))
4117                  (when make-vcell
4118                    (with-node-temps () (vcell closed)
4119                        (arm2-stack-to-register seg vloc closed)
4120                        (if closed-downward
4121                          (progn
4122                            (! make-stack-vcell vcell closed)
4123                            (arm2-open-undo $undostkblk))
4124                          (! make-vcell vcell closed))
4125                        (arm2-register-to-stack seg vcell vloc))))))))))))
4126
4127
4128
4129;;; Never make a vcell if this is an inherited var.
4130;;; If the var's inherited, its bits won't be a fixnum (and will
4131;;; therefore be different from what NX-VAR-BITS returns.)
4132(defun arm2-bind-var (seg var vloc &optional lcell &aux 
4133                          (bits (nx-var-bits var)) 
4134                          (closed-p (and (%ilogbitp $vbitclosed bits) (%ilogbitp $vbitsetq bits)))
4135                          (closed-downward (if closed-p (%ilogbitp $vbitcloseddownward bits)))
4136                          (make-vcell (and closed-p (eq bits (var-bits var))))
4137                          (addr (arm2-vloc-ea vloc)))
4138  (with-arm-local-vinsn-macros (seg)
4139    (if (%ilogbitp $vbitspecial bits)
4140      (progn
4141        (arm2-dbind seg addr (var-name var))
4142        (arm2-set-var-ea seg var (arm2-vloc-ea (- *arm2-vstack* *arm2-target-node-size*)))
4143        t)
4144      (progn
4145        (when (%ilogbitp $vbitpunted bits)
4146          (compiler-bug "bind-var: var ~s was punted" var))
4147        (when make-vcell
4148          (with-node-temps () (vcell closed)
4149            (arm2-stack-to-register seg vloc closed)
4150            (if closed-downward
4151              (progn
4152                (! make-stack-vcell vcell closed)
4153                (arm2-open-undo $undostkblk))
4154              (! make-vcell vcell closed))
4155            (arm2-register-to-stack seg vcell vloc)))
4156        (when lcell
4157          (setf (lcell-kind lcell) :node
4158                (lcell-attributes lcell) bits
4159                (lcell-info lcell) var)
4160          (arm2-note-var-cell var lcell))         
4161        (arm2-set-var-ea seg var (arm2-vloc-ea vloc closed-p))       
4162        closed-downward))))
4163
4164(defun arm2-set-var-ea (seg var ea)
4165  (setf (var-ea var) ea)
4166  (when (and *arm2-record-symbols* (or (typep ea 'lreg) (typep ea 'fixnum)))
4167    (let* ((start (arm2-emit-note seg :begin-variable-scope)))
4168      (push (list var (var-name var) start (close-vinsn-note start))
4169            *arm2-recorded-symbols*)))
4170  ea)
4171
4172(defun arm2-close-var (seg var)
4173  (let ((bits (nx-var-bits var)))
4174    (when (and *arm2-record-symbols*
4175               (or (logbitp $vbitspecial bits)
4176                   (not (logbitp $vbitpunted bits))))
4177      (let ((endnote (%car (%cdddr (assq var *arm2-recorded-symbols*)))))
4178        (unless endnote (compiler-bug "arm2-close-var for ~s ?" (var-name var)))
4179        (setf (vinsn-note-class endnote) :end-variable-scope)
4180        (append-dll-node (vinsn-note-label endnote) seg)))))
4181
4182(defun arm2-load-ea-p (ea)
4183  (or (typep ea 'fixnum)
4184      (typep ea 'lreg)
4185      (typep ea 'lcell)))
4186
4187(defun arm2-dbind (seg value sym)
4188  (with-arm-local-vinsn-macros (seg)
4189    (let* ((ea-p (arm2-load-ea-p value))
4190           (nil-p (unless ea-p (nx-null (setq value (nx-untyped-form value)))))
4191           (self-p (unless ea-p (and (or
4192                                      (eq (acode-operator value) (%nx1-operator bound-special-ref))
4193                                      (eq (acode-operator value) (%nx1-operator special-ref)))
4194                                     (eq (cadr value) sym)))))
4195      (cond ((eq sym '*interrupt-level*)
4196             (let* ((fixval (acode-fixnum-form-p value)))
4197               (cond ((eql fixval 0) (if *arm2-open-code-inline*
4198                                       (! bind-interrupt-level-0-inline)
4199                                       (! bind-interrupt-level-0)))
4200                     ((eql fixval -1) (if