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

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

Split ARM2-ASET2 into the case that has to deal with the write
barrier and all other cases. (The write-barrier case needs to
ultimately get vector/index/new-value into arg_x/arg_y/arg_z;
the other cases have more flexibility.

Multiple-value aref/aset: don't treat indices as constants unless
reckless, not memoizing.

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