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

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

compute 2d unscaled index (via !2d-unscaled-index) in ARM2-ASET2-VIA-GVSET

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