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

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

arm-arch.lisp: get ARM::MAX-64-BIT-CONSTANT-INDEX right for the

(relatively) new order.

arm2.lisp: arm2-vref1,arm2-vset1: use 255 for max constant index for

single-float-vector

arm2-reg-for-form: make sure that single-/double-float-zero is a
register-spec

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(defun arm2-lcell-to-register (seg lcell reg)
1345  (with-arm-local-vinsn-macros (seg)
1346    (! lcell-load reg lcell (arm2-vstack-mark-top))))
1347
1348(defun arm2-register-to-lcell (seg reg lcell)
1349  (with-arm-local-vinsn-macros (seg)
1350    (! lcell-store reg lcell (arm2-vstack-mark-top))))
1351
1352(defun arm2-register-to-stack (seg reg memspec)
1353  (with-arm-local-vinsn-macros (seg)
1354    (let* ((offset (memspec-frame-address-offset memspec))
1355           (vinsn (! vframe-store reg offset *arm2-vstack*)))
1356      (arm2-regmap-note-store (%hard-regspec-value reg) offset)
1357      vinsn)))
1358
1359
1360(defun arm2-ea-open (ea)
1361  (if (and ea (not (typep ea 'lreg)) (addrspec-vcell-p ea))
1362    (make-memory-spec (memspec-frame-address-offset ea))
1363    ea))
1364
1365(defun arm2-set-NARGS (seg n)
1366  (if (> n call-arguments-limit)
1367    (compiler-bug "~s exceeded." call-arguments-limit)
1368    (if (< n 256)     
1369      (with-arm-local-vinsn-macros (seg)
1370        (! set-nargs n))
1371      (arm2-lri seg arm::nargs (ash n arm::word-shift)))))
1372
1373(defun arm2-single-float-bits (the-sf)
1374  (single-float-bits the-sf))
1375
1376(defun arm2-double-float-bits (the-df)
1377  (double-float-bits the-df))
1378
1379(defun arm2-immediate (seg vreg xfer form)
1380  (with-arm-local-vinsn-macros (seg vreg xfer)
1381    (if vreg
1382      (if (and (= (hard-regspec-class vreg) hard-reg-class-fpr)
1383               (or (and (typep form 'double-float) (= (get-regspec-mode vreg) hard-reg-class-fpr-mode-double))
1384                   (and (typep form 'short-float)(= (get-regspec-mode vreg) hard-reg-class-fpr-mode-single))))
1385        (if (zerop form)
1386          (if (eql form 0.0d0)
1387            (! zero-double-float-register vreg)
1388            (! zero-single-float-register vreg))
1389          (if (typep form 'short-float)
1390            (let* ((bits (arm2-single-float-bits form)))
1391              (with-imm-temps () ((bitsreg :u32))
1392                (! lri bitsreg bits)
1393                (! load-single-float-constant vreg bitsreg)))
1394            (multiple-value-bind (high low) (arm2-double-float-bits form)
1395              (declare (integer high low))
1396              (! load-double-float-constant-from-data vreg high low))))
1397        (if (and (typep form '(unsigned-byte 32))
1398                 (= (hard-regspec-class vreg) hard-reg-class-gpr)
1399                 (= (get-regspec-mode vreg)
1400                    hard-reg-class-gpr-mode-u32))
1401          (arm2-lri seg vreg form)
1402          (ensuring-node-target (target vreg)
1403            (let* ((regno (hard-regspec-value target))
1404                   (regs (arm2-gprs-containing-constant form)))
1405              (unless (logbitp regno regs)
1406                (if (eql 0 regs)
1407                  (if (characterp form)
1408                    (! load-character-constant target (char-code form))
1409                    (arm2-store-immediate seg form target))
1410                  (let* ((r (1- (integer-length regs))))
1411                    (! copy-node-gpr target r)))
1412                (setf *arm2-gpr-constants-valid-mask*
1413                      (logior *arm2-gpr-constants-valid-mask*
1414                              (ash 1 regno))
1415                      (svref *arm2-gpr-constants* regno) form))))))
1416        (if (and (listp form) *load-time-eval-token* (eq (car form) *load-time-eval-token*))
1417          (arm2-store-immediate seg form ($ arm::temp0))))
1418    (^)))
1419
1420(defun arm2-register-constant-p (form)
1421  (and (consp form)
1422           (or (memq form *arm2-vcells*)
1423               (memq form *arm2-fcells*))
1424           (%cdr form)))
1425
1426(defun arm2-store-immediate (seg imm dest)
1427  (with-arm-local-vinsn-macros (seg)
1428    (let* ((reg (arm2-register-constant-p imm)))
1429      (if reg
1430        (arm2-copy-register seg dest reg)
1431        (let* ((idx (backend-immediate-index imm)))
1432          (if (< idx 4094)
1433            (! ref-constant dest idx)
1434            (with-imm-target () (idxreg :s32)
1435              (arm2-lri seg idxreg (+ arm::misc-data-offset (ash (1+ idx) 2)))
1436              (! ref-indexed-constant dest idxreg)))))
1437      dest)))
1438
1439
1440;;; Returns label iff form is (local-go <tag>) and can go without adjusting stack.
1441(defun arm2-go-label (form)
1442  (let ((current-stack (arm2-encode-stack)))
1443    (while (and (acode-p form) (or (eq (acode-operator form) (%nx1-operator progn))
1444                                   (eq (acode-operator form) (%nx1-operator local-tagbody))))
1445      (setq form (caadr form)))
1446    (when (acode-p form)
1447      (let ((op (acode-operator form)))
1448        (if (and (eq op (%nx1-operator local-go))
1449                 (arm2-equal-encodings-p (%caddr (%cadr form)) current-stack))
1450          (%cadr (%cadr form))
1451          (if (and (eq op (%nx1-operator local-return-from))
1452                   (nx-null (caddr form)))
1453            (let ((tagdata (car (cadr form))))
1454              (and (arm2-equal-encodings-p (cdr tagdata) current-stack)
1455                   (null (caar tagdata))
1456                   (< 0 (cdar tagdata) $backend-mvpass)
1457                   (cdar tagdata)))))))))
1458
1459(defun arm2-single-valued-form-p (form)
1460  (setq form (acode-unwrapped-form-value form))
1461  (or (nx-null form)
1462      (nx-t form)
1463      (if (acode-p form)
1464        (let ((op (acode-operator form)))
1465          (or (%ilogbitp operator-single-valued-bit op)
1466              (and (eql op (%nx1-operator values))
1467                   (let ((values (cadr form)))
1468                     (and values (null (cdr values)))))
1469              nil                       ; Learn about functions someday
1470              )))))
1471
1472
1473(defun arm2-box-s32 (seg node-dest s32-src)
1474  (with-arm-local-vinsn-macros (seg)
1475    (if *arm2-open-code-inline*
1476      (! s32->integer node-dest s32-src)
1477      (let* ((arg_z ($ arm::arg_z))
1478             (imm0 ($ arm::imm0 :mode :s32)))
1479        (arm2-copy-register seg imm0 s32-src)
1480        (! call-subprim (arm::arm-subprimitive-offset '.SPmakes32))
1481        (arm2-copy-register seg node-dest arg_z)))))
1482
1483
1484
1485(defun arm2-box-u32 (seg node-dest u32-src)
1486  (with-arm-local-vinsn-macros (seg)
1487    (if *arm2-open-code-inline*
1488      (! u32->integer node-dest u32-src)
1489      (let* ((arg_z ($ arm::arg_z))
1490             (imm0 ($ arm::imm0 :mode :u32)))
1491        (arm2-copy-register seg imm0 u32-src)
1492        (! call-subprim (arm::arm-subprimitive-offset '.SPmakeu32))
1493        (arm2-copy-register seg node-dest arg_z)))))
1494
1495
1496
1497(defun arm2-vref1 (seg vreg xfer type-keyword src unscaled-idx index-known-fixnum)
1498  (with-arm-local-vinsn-macros (seg vreg xfer)
1499    (when vreg
1500      (let* ((arch (backend-target-arch *target-backend*))
1501             (is-node (member type-keyword (arch::target-gvector-types arch)))
1502             (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch)))
1503
1504             (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
1505             (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
1506             (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
1507             (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
1508             (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector)))
1509             (vreg-class (hard-regspec-class vreg))
1510             (vreg-mode
1511              (if (or (eql vreg-class hard-reg-class-gpr)
1512                      (eql vreg-class hard-reg-class-fpr))
1513                (get-regspec-mode vreg)
1514                hard-reg-class-gpr-mode-invalid))
1515             (temp-is-vreg nil))
1516        (cond
1517          (is-node
1518           (ensuring-node-target (target vreg)
1519             (if (and index-known-fixnum (<= index-known-fixnum
1520                                             (arch::target-max-32-bit-constant-index arch)))
1521               (! misc-ref-c-node target src index-known-fixnum)
1522               (with-imm-target () (idx-reg :u64)
1523                 (if index-known-fixnum
1524                   (arm2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum *arm2-target-node-shift*)))
1525                   (! scale-node-misc-index idx-reg unscaled-idx))
1526                 (! misc-ref-node target src idx-reg)))))
1527          (is-32-bit
1528           (with-imm-target () (temp :u32)
1529             (with-fp-target () (fp-val :single-float)
1530               (if (eql vreg-class hard-reg-class-gpr)
1531                 (if
1532                   (if is-signed
1533                     (or (eql vreg-mode hard-reg-class-gpr-mode-s32)
1534                         (eql vreg-mode hard-reg-class-gpr-mode-s64))
1535                     (or (eql vreg-mode hard-reg-class-gpr-mode-u32)
1536                         (eql vreg-mode hard-reg-class-gpr-mode-u64)))
1537                   (setq temp vreg temp-is-vreg t)
1538                   (if is-signed
1539                     (set-regspec-mode temp hard-reg-class-gpr-mode-s32)))
1540                 (if (and (eql vreg-class hard-reg-class-fpr)
1541                          (eql vreg-mode hard-reg-class-fpr-mode-single))
1542                   (setf fp-val vreg temp-is-vreg t)))
1543               (if (and index-known-fixnum (<= index-known-fixnum
1544                                               (if (eq type-keyword :single-float-vector)
1545                                                 255
1546                                                 (arch::target-max-32-bit-constant-index arch))))
1547                 (cond ((eq type-keyword :single-float-vector)
1548                        (! misc-ref-c-single-float fp-val src index-known-fixnum))
1549                       (t
1550                        (if is-signed
1551                          (! misc-ref-c-s32 temp src index-known-fixnum)
1552                          (! misc-ref-c-u32 temp src index-known-fixnum))))
1553                 (with-imm-target () idx-reg
1554                   (if index-known-fixnum
1555                     (arm2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
1556                     (! scale-32bit-misc-index idx-reg unscaled-idx))
1557                   (cond ((eq type-keyword :single-float-vector)
1558                          (! misc-ref-single-float fp-val src idx-reg))
1559                         (t
1560                          (if is-signed
1561                            (! misc-ref-s32 temp src idx-reg)
1562                            (! misc-ref-u32 temp src idx-reg))))))
1563               (case type-keyword
1564                 (:single-float-vector
1565                  (if (eq vreg-class hard-reg-class-fpr)
1566                    (<- fp-val)
1567                    (ensuring-node-target (target vreg)
1568                      (! single->node target fp-val))))
1569                 (:signed-32-bit-vector
1570                  (unless temp-is-vreg
1571                    (ensuring-node-target (target vreg)
1572                      (arm2-box-s32 seg target temp))))
1573                 (:fixnum-vector
1574                  (unless temp-is-vreg
1575                    (ensuring-node-target (target vreg)
1576                      (! box-fixnum target temp))))
1577                 (:simple-string
1578                  (ensuring-node-target (target vreg)
1579                    (! u32->char target temp)))
1580                 (t
1581                  (unless temp-is-vreg
1582                    (ensuring-node-target (target vreg)
1583                      (arm2-box-u32 seg target temp))))))))
1584          (is-8-bit
1585           (with-imm-target () (temp :u8)
1586             (if (and (eql vreg-class hard-reg-class-gpr)
1587                      (or
1588                       (and is-signed
1589                            (or (eql vreg-mode hard-reg-class-gpr-mode-s8)
1590                                (eql vreg-mode hard-reg-class-gpr-mode-s16)
1591                                (eql vreg-mode hard-reg-class-gpr-mode-s32)
1592                                (eql vreg-mode hard-reg-class-gpr-mode-s64)))
1593                       (and (not is-signed)
1594                            (or (eql vreg-mode hard-reg-class-gpr-mode-u8)
1595                                (eql vreg-mode hard-reg-class-gpr-mode-s16)
1596                                (eql vreg-mode hard-reg-class-gpr-mode-u16)
1597                                (eql vreg-mode hard-reg-class-gpr-mode-s32)
1598                                (eql vreg-mode hard-reg-class-gpr-mode-u32)
1599                                (eql vreg-mode hard-reg-class-gpr-mode-s64)
1600                                (eql vreg-mode hard-reg-class-gpr-mode-u64)))))
1601               (setq temp vreg temp-is-vreg t)
1602               (if is-signed
1603                 (set-regspec-mode temp hard-reg-class-gpr-mode-s8)))
1604             (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-8-bit-constant-index arch)))
1605               (if is-signed
1606                 (! misc-ref-c-s8 temp src index-known-fixnum)
1607                 (! misc-ref-c-u8 temp src index-known-fixnum))
1608               (with-imm-target () idx-reg
1609                 (if index-known-fixnum
1610                   (arm2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) index-known-fixnum))
1611                   (! scale-8bit-misc-index idx-reg unscaled-idx))
1612                 (if is-signed
1613                   (! misc-ref-s8 temp src idx-reg)
1614                   (! misc-ref-u8 temp src idx-reg))))
1615             (ecase type-keyword
1616               (:unsigned-8-bit-vector
1617                (unless temp-is-vreg
1618                  (ensuring-node-target (target vreg)
1619                    (! box-fixnum target temp))))
1620               (:signed-8-bit-vector
1621                (unless temp-is-vreg
1622                  (ensuring-node-target (target vreg)
1623                    (! box-fixnum target temp))))
1624               (:simple-string
1625                (ensuring-node-target (target vreg)
1626                  (! u32->char target temp))))))
1627          (is-16-bit
1628           (ensuring-node-target (target vreg)
1629             (with-imm-target () temp
1630               (if (and index-known-fixnum
1631                        (<= index-known-fixnum (arch::target-max-16-bit-constant-index arch)))
1632                 (if is-signed
1633                   (! misc-ref-c-s16 temp src index-known-fixnum)
1634                   (! misc-ref-c-u16 temp src index-known-fixnum))
1635                 (with-imm-target () idx-reg
1636                   (if index-known-fixnum
1637                     (arm2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1)))
1638                     (! scale-16bit-misc-index idx-reg unscaled-idx))
1639                   (if is-signed
1640                     (! misc-ref-s16 temp src idx-reg)
1641                     (! misc-ref-u16 temp src idx-reg))))
1642               (! box-fixnum target temp))))
1643          (is-64-bit
1644           (with-fp-target () (fp-val :double-float)
1645             (with-imm-target () (temp :u64)
1646               (if (and (eql vreg-class hard-reg-class-fpr)
1647                        (eql vreg-mode hard-reg-class-fpr-mode-double))
1648                 (setq fp-val vreg)
1649                 (if (eql vreg-class hard-reg-class-gpr)
1650                   (if (or (and is-signed
1651                                (eql vreg-mode hard-reg-class-gpr-mode-s64))
1652                           (and (not is-signed)
1653                                (eql vreg-mode hard-reg-class-gpr-mode-u64)))
1654                     (setf temp vreg temp-is-vreg t)
1655                     (if is-signed
1656                       (set-regspec-mode temp hard-reg-class-gpr-mode-s64)))))
1657               (case type-keyword
1658                 (:double-float-vector
1659                  (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1660                    (! misc-ref-c-double-float fp-val src index-known-fixnum)
1661                    (with-imm-target () idx-reg
1662                      (if index-known-fixnum
1663                        (unless unscaled-idx
1664                          (setq unscaled-idx idx-reg)
1665                          (arm2-absolute-natural seg unscaled-idx nil (ash index-known-fixnum arm::fixnumshift))))
1666                      (! misc-ref-double-float fp-val src unscaled-idx)))
1667                  (if (eq vreg-class hard-reg-class-fpr)
1668                    (<- fp-val)
1669                    (ensuring-node-target (target vreg)
1670                      (! double->heap target fp-val))))
1671                 ((:signed-64-bit-vector :fixnum-vector)
1672                  (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1673                    (! misc-ref-c-s64 temp src index-known-fixnum)
1674                    (with-imm-target () idx-reg
1675                      (if index-known-fixnum
1676                        (arm2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3)))
1677                        (! scale-64bit-misc-index idx-reg unscaled-idx))
1678                      (! misc-ref-s64 temp src idx-reg)))
1679                  (if (eq type-keyword :fixnum-vector)
1680                    (ensuring-node-target (target vreg)
1681                      (! box-fixnum target temp))
1682                    (unless temp-is-vreg
1683                      (ensuring-node-target (target vreg)
1684                        (! s64->integer target temp)))))
1685                 (t
1686                  (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-64-bit-constant-index arch)))
1687                    (! misc-ref-c-u64 temp src index-known-fixnum)
1688                    (with-imm-target () idx-reg
1689                      (if index-known-fixnum
1690                        (arm2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 3)))
1691                        (! scale-64bit-misc-index idx-reg unscaled-idx))
1692                      (! misc-ref-u64  temp src idx-reg)))
1693                  (unless temp-is-vreg
1694                    (ensuring-node-target (target vreg)
1695                      (! u64->integer target temp))))))))
1696          (t
1697           (unless is-1-bit
1698             (nx-error "~& unsupported vector type: ~s"
1699                       type-keyword))
1700           (ensuring-node-target (target vreg)
1701             (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch)))
1702               (! misc-ref-c-bit-fixnum target src index-known-fixnum)
1703               (with-imm-temps () (word-index bitnum)
1704                 (if index-known-fixnum
1705                   (progn
1706                     (arm2-lri seg word-index (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum -5)))
1707                     (arm2-lri seg bitnum (logand index-known-fixnum #x1f)))
1708                   (! scale-1bit-misc-index word-index bitnum unscaled-idx))
1709                 (let* ((dest word-index))
1710                   (! misc-ref-u32 dest src word-index)
1711                   (! extract-variable-bit-fixnum target dest bitnum)))))))))
1712    (^)))
1713             
1714   
1715
1716;;; safe = T means assume "vector" is miscobj, do bounds check.
1717;;; safe = fixnum means check that subtag of vector = "safe" and do
1718;;;        bounds check.
1719;;; safe = nil means crash&burn.
1720;;; This mostly knows how to reference the elements of an immediate miscobj.
1721(defun arm2-vref (seg vreg xfer type-keyword vector index safe)
1722  (with-arm-local-vinsn-macros (seg vreg xfer)
1723    (let* ((index-known-fixnum (acode-fixnum-form-p index))
1724           (unscaled-idx nil)
1725           (src nil))
1726      (if (or safe (not index-known-fixnum))
1727        (multiple-value-setq (src unscaled-idx)
1728          (arm2-two-untargeted-reg-forms seg vector arm::arg_y index arm::arg_z))
1729        (setq src (arm2-one-untargeted-reg-form seg vector arm::arg_z)))
1730      (when safe
1731        (if (typep safe 'fixnum)
1732          (! trap-unless-typecode= src safe))
1733        (unless index-known-fixnum
1734          (! trap-unless-fixnum unscaled-idx))
1735        (! check-misc-bound unscaled-idx src))
1736      (arm2-vref1 seg vreg xfer type-keyword src unscaled-idx index-known-fixnum))))
1737
1738
1739(defun arm2-aset2-via-gvset (seg vreg xfer  array i j new safe type-keyword  constval)
1740  (with-arm-local-vinsn-macros (seg vreg xfer)
1741    (let* ((i-known-fixnum (acode-fixnum-form-p i))
1742           (j-known-fixnum (acode-fixnum-form-p j))
1743           (src ($ arm::temp0))
1744           (unscaled-i ($ arm::arg_x))
1745           (unscaled-j ($ arm::arg_y))
1746           (val-reg ($ arm::arg_z)))
1747      (arm2-four-targeted-reg-forms seg
1748                                    array src
1749                                    i unscaled-i
1750                                    j unscaled-j
1751                                    new val-reg)
1752      (when safe
1753        (when (typep safe 'fixnum)
1754          (with-node-target (src unscaled-i unscaled-j val-reg) expected 
1755            (! lri expected
1756               (ash (dpb safe target::arrayH.flags-cell-subtag-byte
1757                         (ash 1 $arh_simple_bit))
1758                    arm::fixnumshift))
1759            (! trap-unless-simple-array-2 src expected)))
1760        (unless i-known-fixnum
1761          (! trap-unless-fixnum unscaled-i))
1762        (unless j-known-fixnum
1763          (! trap-unless-fixnum unscaled-j)))
1764      (with-imm-target () dim1
1765        (let* ((idx-reg ($ arm::arg_y)))
1766          (if safe                 
1767            (! check-2d-bound dim1 unscaled-i unscaled-j src)
1768            (! 2d-dim1 dim1 src))
1769          (let* ((v ($ arm::arg_x)))
1770            (! array-data-vector-ref v src)
1771            (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)))))))
1772     
1773 
1774(defun arm2-aset2 (seg vreg xfer  array i j new safe type-keyword dim0 dim1)
1775  (with-arm-local-vinsn-macros (seg vreg xfer)
1776    (let* ((i-known-fixnum (acode-fixnum-form-p i))
1777           (j-known-fixnum (acode-fixnum-form-p j))
1778           (arch (backend-target-arch *target-backend*))
1779           (is-node (member type-keyword (arch::target-gvector-types arch)))
1780           (constval (arm2-constant-value-ok-for-type-keyword type-keyword new))
1781           (needs-memoization (and is-node (arm2-acode-needs-memoization new))))
1782      (if needs-memoization
1783        (arm2-aset2-via-gvset seg vreg xfer array i j new safe type-keyword constval)
1784        (let* ((constidx
1785                (and *arm2-reckless*
1786                     dim0 dim1 i-known-fixnum j-known-fixnum
1787                     (>= i-known-fixnum 0)
1788                     (>= j-known-fixnum 0)
1789                     (< i-known-fixnum dim0)
1790                     (< j-known-fixnum dim1)
1791                     (+ (* i-known-fixnum dim1) j-known-fixnum)))
1792               (val-reg (arm2-target-reg-for-aset vreg type-keyword))
1793               (node-val (if (node-reg-p val-reg) val-reg))
1794               (imm-val (if (imm-reg-p val-reg) val-reg)))
1795          (with-node-target (node-val) src
1796            (with-node-target (node-val src) unscaled-i
1797              (with-node-target (node-val src unscaled-i) unscaled-j
1798                (if constidx
1799                  (multiple-value-setq (src val-reg)
1800                    (arm2-two-untargeted-reg-forms seg array ($ arm::temp0) new val-reg))
1801                  (multiple-value-setq (src unscaled-i unscaled-j val-reg)
1802                    (arm2-four-untargeted-reg-forms seg
1803                                                    array src
1804                                                    i unscaled-i
1805                                                    j unscaled-j
1806                                                    new val-reg)))
1807                (if (node-reg-p val-reg) (setq node-val val-reg))
1808                (if (imm-reg-p val-reg) (setq imm-val val-reg))
1809                (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)
1810                       )
1811                  (when (and (= (hard-regspec-class val-reg) hard-reg-class-gpr)
1812                             (logbitp (hard-regspec-value val-reg)
1813                                      *backend-imm-temps*))
1814                    (use-imm-temp (hard-regspec-value val-reg)))
1815                  (when safe     
1816                    (when (typep safe 'fixnum)
1817                      (with-node-target (src node-val unscaled-i unscaled-j) expected
1818                        (! lri expected
1819                           (ash (dpb safe target::arrayH.flags-cell-subtag-byte
1820                                     (ash 1 $arh_simple_bit))
1821                                arm::fixnumshift))
1822                        (! trap-unless-simple-array-2 src expected)))
1823                    (unless i-known-fixnum
1824                      (! trap-unless-fixnum unscaled-i))
1825                    (unless j-known-fixnum
1826                      (! trap-unless-fixnum unscaled-j)))
1827                  (with-imm-target (imm-val) dim1
1828                    (with-node-target (src node-val) idx-reg
1829                      (unless constidx
1830                        (if safe                 
1831                          (! check-2d-bound dim1 unscaled-i unscaled-j src)
1832                          (! 2d-dim1 dim1 src))
1833                        (! 2d-unscaled-index idx-reg dim1 unscaled-i unscaled-j))
1834                      (with-node-target (idx-reg node-val) v
1835                        (! array-data-vector-ref v src)
1836                        (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)))))))))))))
1837
1838
1839(defun arm2-aset3 (seg vreg xfer  array i j k new safe type-keyword  dim0 dim1 dim2)
1840  (with-arm-local-vinsn-macros (seg target)
1841    (let* ((i-known-fixnum (acode-fixnum-form-p i))
1842           (j-known-fixnum (acode-fixnum-form-p j))
1843           (k-known-fixnum (acode-fixnum-form-p k))
1844           (arch (backend-target-arch *target-backend*))
1845           (is-node (member type-keyword (arch::target-gvector-types arch)))
1846           (constval (arm2-constant-value-ok-for-type-keyword type-keyword new))
1847           (needs-memoization (and is-node (arm2-acode-needs-memoization new)))
1848           (src)
1849           (unscaled-i)
1850           (unscaled-j)
1851           (unscaled-k)
1852           (val-reg (arm2-target-reg-for-aset vreg type-keyword))
1853           (constidx
1854            (and *arm2-reckless*
1855                 (not needs-memoization) dim0 dim1 dim2 i-known-fixnum j-known-fixnum k-known-fixnum
1856                 (>= i-known-fixnum 0)
1857                 (>= j-known-fixnum 0)
1858                 (>= k-known-fixnum 0)
1859                 (< i-known-fixnum dim0)
1860                 (< j-known-fixnum dim1)
1861                 (< k-known-fixnum dim2)
1862                 (+ (* i-known-fixnum dim1 dim2)
1863                    (* j-known-fixnum dim2)
1864                    k-known-fixnum))))
1865      (progn
1866        (if constidx
1867          (multiple-value-setq (src val-reg)
1868            (arm2-two-targeted-reg-forms seg array ($ arm::temp0) new val-reg))
1869          (progn
1870            (setq src ($ arm::temp1)
1871                  unscaled-i ($ arm::temp0)
1872                  unscaled-j ($ arm::arg_x)
1873                  unscaled-k ($ arm::arg_y))
1874            (arm2-push-register
1875             seg
1876             (arm2-one-untargeted-reg-form seg array ($ arm::arg_z)))
1877            (arm2-four-targeted-reg-forms seg
1878                                          i ($ arm::temp0)
1879                                          j ($ arm::arg_x)
1880                                          k ($ arm::arg_y)
1881                                          new val-reg)
1882            (arm2-pop-register seg src)))
1883        (let* ((*available-backend-imm-temps* *available-backend-imm-temps*))
1884          (when (and (= (hard-regspec-class val-reg) hard-reg-class-gpr)
1885                     (logbitp (hard-regspec-value val-reg)
1886                              *backend-imm-temps*))
1887            (use-imm-temp (hard-regspec-value val-reg)))
1888
1889          (when safe     
1890            (when (typep safe 'fixnum)
1891              (let* ((expected (if constidx
1892                                 (with-node-target (src val-reg) expected
1893                                   expected)
1894                                 (with-node-target (src unscaled-i unscaled-j unscaled-k val-reg) expected
1895                                   expected))))
1896                (! lri expected (ash (dpb safe target::arrayH.flags-cell-subtag-byte
1897                                          (ash 1 $arh_simple_bit))
1898                                     arm::fixnumshift))
1899              (! trap-unless-simple-array-3
1900                 src
1901                 expected)))
1902            (unless i-known-fixnum
1903              (! trap-unless-fixnum unscaled-i))
1904            (unless j-known-fixnum
1905              (! trap-unless-fixnum unscaled-j))
1906            (unless k-known-fixnum
1907              (! trap-unless-fixnum unscaled-k)))
1908          (with-imm-target () dim1
1909            (with-imm-target (dim1) dim2
1910              (let* ((idx-reg ($ arm::arg_y)))
1911                (unless constidx
1912                  (if safe                 
1913                    (! check-3d-bound dim1 dim2 unscaled-i unscaled-j unscaled-k src)
1914                    (! 3d-dims dim1 dim2 src))
1915                  (! 3d-unscaled-index idx-reg dim1 dim2 unscaled-i unscaled-j unscaled-k))
1916                (let* ((v ($ arm::arg_x)))
1917                  (! array-data-vector-ref v src)
1918                  (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))))))))))
1919
1920(defun arm2-aref2 (seg vreg xfer array i j safe typekeyword &optional dim0 dim1)
1921  (with-arm-local-vinsn-macros (seg vreg xfer)
1922    (let* ((i-known-fixnum (acode-fixnum-form-p i))
1923           (j-known-fixnum (acode-fixnum-form-p j))
1924           (src)
1925           (unscaled-i)
1926           (unscaled-j)
1927           (constidx
1928            (and *arm2-reckless*
1929                 dim0 dim1 i-known-fixnum j-known-fixnum
1930                 (>= i-known-fixnum 0)
1931                 (>= j-known-fixnum 0)
1932                 (< i-known-fixnum dim0)
1933                 (< j-known-fixnum dim1)
1934                 (+ (* i-known-fixnum dim1) j-known-fixnum))))
1935      (if constidx
1936        (setq src (arm2-one-targeted-reg-form seg array ($ arm::arg_z)))
1937        (multiple-value-setq (src unscaled-i unscaled-j)
1938          (arm2-three-untargeted-reg-forms seg
1939                                           array arm::arg_x
1940                                           i arm::arg_y
1941                                           j arm::arg_z)))
1942      (when safe       
1943        (when (typep safe 'fixnum)
1944          (let* ((*available-backend-node-temps* *available-backend-node-temps*))
1945            (when unscaled-i
1946              (setq *available-backend-node-temps* (logandc2 *available-backend-node-temps*
1947                                                             (ash 1 (hard-regspec-value unscaled-i)))))
1948            (when unscaled-j
1949              (setq *available-backend-node-temps* (logandc2 *available-backend-node-temps*
1950                                                             (ash 1 (hard-regspec-value unscaled-j)))))
1951            (with-node-target (src) expected
1952              (! lri expected (ash (dpb safe target::arrayH.flags-cell-subtag-byte
1953                                        (ash 1 $arh_simple_bit))
1954                                   arm::fixnumshift))
1955              (! trap-unless-simple-array-2 src expected))))
1956        (unless i-known-fixnum
1957          (! trap-unless-fixnum unscaled-i))
1958        (unless j-known-fixnum
1959          (! trap-unless-fixnum unscaled-j)))
1960      (with-node-target (src) idx-reg
1961        (with-imm-target () dim1
1962          (unless constidx
1963            (if safe                   
1964              (! check-2d-bound dim1 unscaled-i unscaled-j src)
1965              (! 2d-dim1 dim1 src))
1966            (! 2d-unscaled-index idx-reg dim1 unscaled-i unscaled-j))
1967          (with-node-target (idx-reg src) v
1968            (! array-data-vector-ref v src)
1969            (arm2-vref1 seg vreg xfer typekeyword v idx-reg constidx)))))))
1970
1971
1972
1973(defun arm2-aref3 (seg vreg xfer array i j k safe typekeyword &optional dim0 dim1 dim2)
1974  (with-arm-local-vinsn-macros (seg vreg xfer)
1975    (let* ((i-known-fixnum (acode-fixnum-form-p i))
1976           (j-known-fixnum (acode-fixnum-form-p j))
1977           (k-known-fixnum (acode-fixnum-form-p k))
1978           (src)
1979           (unscaled-i)
1980           (unscaled-j)
1981           (unscaled-k)
1982           (constidx
1983            (and *arm2-reckless*
1984                 dim0 dim1 i-known-fixnum j-known-fixnum k-known-fixnum
1985                 (>= i-known-fixnum 0)
1986                 (>= j-known-fixnum 0)
1987                 (>= k-known-fixnum 0)
1988                 (< i-known-fixnum dim0)
1989                 (< j-known-fixnum dim1)
1990                 (< k-known-fixnum dim2)
1991                 (+ (* i-known-fixnum dim1 dim2)
1992                    (* j-known-fixnum dim2)
1993                    k-known-fixnum))))
1994      (if constidx
1995        (setq src (arm2-one-targeted-reg-form seg array ($ arm::arg_z)))
1996        (multiple-value-setq (src unscaled-i unscaled-j unscaled-k)
1997          (arm2-four-untargeted-reg-forms seg
1998                                           array arm::temp0
1999                                           i arm::arg_x
2000                                           j arm::arg_y
2001                                           k arm::arg_z)))
2002      (when safe       
2003        (when (typep safe 'fixnum)
2004          (let* ((expected (if constidx
2005                             (with-node-target (src) expected
2006                               expected)
2007                             (with-node-target (src unscaled-i unscaled-j unscaled-k) expected
2008                               expected))))
2009            (! lri expected (ash (dpb safe target::arrayH.flags-cell-subtag-byte
2010                                      (ash 1 $arh_simple_bit))
2011                                 arm::fixnumshift))
2012            (! trap-unless-simple-array-3 src expected)))
2013        (unless i-known-fixnum
2014          (! trap-unless-fixnum unscaled-i))
2015        (unless j-known-fixnum
2016          (! trap-unless-fixnum unscaled-j))
2017        (unless k-known-fixnum
2018          (! trap-unless-fixnum unscaled-k)))
2019      (with-node-target (src) idx-reg
2020        (with-imm-target () dim1
2021          (with-imm-target (dim1) dim2
2022            (unless constidx
2023              (if safe                   
2024                (! check-3d-bound dim1 dim2 unscaled-i unscaled-j unscaled-k src)
2025                (! 3d-dims dim1 dim2 src))
2026              (! 3d-unscaled-index idx-reg dim1 dim2 unscaled-i unscaled-j unscaled-k))))
2027        (with-node-target (idx-reg) v
2028          (! array-data-vector-ref v src)
2029          (arm2-vref1 seg vreg xfer typekeyword v idx-reg constidx))))))
2030
2031
2032(defun arm2-constant-value-ok-for-type-keyword (type-keyword form)
2033  (if (and (acode-p (setq form (acode-unwrapped-form form)))
2034           (or (eq (acode-operator form) (%nx1-operator immediate))
2035               (eq (acode-operator form) (%nx1-operator fixnum))))
2036    (let* ((val (%cadr form))
2037           (typep (cond ((eq type-keyword :signed-32-bit-vector)
2038                         (typep val '(signed-byte 32)))
2039                        ((eq type-keyword :single-float-vector)
2040                         (typep val 'short-float))
2041                        ((eq type-keyword :double-float-vector)
2042                         (typep val 'double-float))
2043                        ((eq type-keyword :simple-string)
2044                         (typep val 'base-char))
2045                        ((eq type-keyword :signed-8-bit-vector)
2046                         (typep val '(signed-byte 8)))
2047                        ((eq type-keyword :unsigned-8-bit-vector)
2048                         (typep val '(unsigned-byte 8)))
2049                        ((eq type-keyword :signed-16-bit-vector) 
2050                         (typep val '(signed-byte 16)))
2051                        ((eq type-keyword :unsigned-16-bit-vector)
2052                         (typep val '(unsigned-byte 16)))
2053                        ((eq type-keyword :bit-vector)
2054                         (typep val 'bit)))))
2055      (if typep val))))
2056
2057(defun arm2-target-reg-for-aset (vreg type-keyword)
2058  (let* ((arch (backend-target-arch *target-backend*))
2059         (is-node (member type-keyword (arch::target-gvector-types arch)))
2060         (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch)))
2061         (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
2062         (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
2063         (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
2064         (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
2065         (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector)))
2066         (vreg-class (if vreg (hard-regspec-class vreg)))
2067         (vreg-mode (if (or (eql vreg-class hard-reg-class-gpr)
2068                            (eql vreg-class hard-reg-class-fpr))
2069                      (get-regspec-mode vreg)))
2070         (next-imm-target (available-imm-temp  *available-backend-imm-temps*))
2071         (next-fp-target (available-fp-temp *available-backend-fp-temps*))
2072         (acc (make-wired-lreg arm::arg_z)))
2073    (cond ((or is-node
2074               is-1-bit
2075               (eq type-keyword :simple-string)
2076               (eq type-keyword :fixnum-vector)
2077               (and (eql vreg-class hard-reg-class-gpr)
2078                    (eql vreg-mode hard-reg-class-gpr-mode-node)))
2079           acc)
2080          ;; If there's no vreg - if we're setting for effect only, and
2081          ;; not for value - we can target an unboxed register directly.
2082          ;; Usually.
2083          ((null vreg)
2084           (cond (is-64-bit
2085                  (if (eq type-keyword :double-float-vector)
2086                    (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-double)
2087                    (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s64 hard-reg-class-gpr-mode-u64))))
2088                 (is-32-bit
2089                  (if (eq type-keyword :single-float-vector)
2090                    (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-single)
2091                    (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s32 hard-reg-class-gpr-mode-u32))))
2092                 (is-16-bit
2093                  (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s16 hard-reg-class-gpr-mode-u16)))
2094                 (is-8-bit
2095                  (make-unwired-lreg next-imm-target :mode (if is-signed hard-reg-class-gpr-mode-s8 hard-reg-class-gpr-mode-u8)))
2096                 (t "Bug: can't determine operand size for ~s" type-keyword)))
2097          ;; Vreg is non-null.  We might be able to use it directly.
2098          (t
2099           (let* ((lreg (if vreg-mode
2100                          (make-unwired-lreg (lreg-value vreg)))))
2101             (if 
2102               (cond
2103                 (is-64-bit
2104                  (if (eq type-keyword :double-float-vector)
2105                    (and (eql vreg-class hard-reg-class-fpr)
2106                         (eql vreg-mode hard-reg-class-fpr-mode-double))
2107                      (if is-signed
2108                        (and (eql vreg-class hard-reg-class-gpr)
2109                                 (eql vreg-mode hard-reg-class-gpr-mode-s64))
2110                        (and (eql vreg-class hard-reg-class-gpr)
2111                                 (eql vreg-mode hard-reg-class-gpr-mode-u64)))))
2112                   (is-32-bit
2113                    (if (eq type-keyword :single-float-vector)
2114                      (and (eql vreg-class hard-reg-class-fpr)
2115                               (eql vreg-mode hard-reg-class-fpr-mode-single))
2116                      (if is-signed
2117                        (and (eql vreg-class hard-reg-class-gpr)
2118                                 (or (eql vreg-mode hard-reg-class-gpr-mode-s32)
2119                                     (eql vreg-mode hard-reg-class-gpr-mode-s64)))
2120                        (and (eql vreg-class hard-reg-class-gpr)
2121                                 (or (eql vreg-mode hard-reg-class-gpr-mode-u32)
2122                                     (eql vreg-mode hard-reg-class-gpr-mode-u64)
2123                                     (eql vreg-mode hard-reg-class-gpr-mode-s64))))))
2124                   (is-16-bit
2125                    (if is-signed
2126                      (and (eql vreg-class hard-reg-class-gpr)
2127                               (or (eql vreg-mode hard-reg-class-gpr-mode-s16)
2128                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
2129                                   (eql vreg-mode hard-reg-class-gpr-mode-s64)))
2130                      (and (eql vreg-class hard-reg-class-gpr)
2131                               (or (eql vreg-mode hard-reg-class-gpr-mode-u16)
2132                                   (eql vreg-mode hard-reg-class-gpr-mode-u32)
2133                                   (eql vreg-mode hard-reg-class-gpr-mode-u64)
2134                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
2135                                   (eql vreg-mode hard-reg-class-gpr-mode-s64)))))
2136                   (t
2137                    (if is-signed
2138                      (and (eql vreg-class hard-reg-class-gpr)
2139                               (or (eql vreg-mode hard-reg-class-gpr-mode-s8)
2140                                   (eql vreg-mode hard-reg-class-gpr-mode-s16)
2141                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
2142                                   (eql vreg-mode hard-reg-class-gpr-mode-s64)))
2143                      (and (eql vreg-class hard-reg-class-gpr)
2144                               (or (eql vreg-mode hard-reg-class-gpr-mode-u8)
2145                                   (eql vreg-mode hard-reg-class-gpr-mode-u16)
2146                                   (eql vreg-mode hard-reg-class-gpr-mode-u32)
2147                                   (eql vreg-mode hard-reg-class-gpr-mode-u64)
2148                                   (eql vreg-mode hard-reg-class-gpr-mode-s16)
2149                                   (eql vreg-mode hard-reg-class-gpr-mode-s32)
2150                                   (eql vreg-mode hard-reg-class-gpr-mode-s64))))))
2151               lreg
2152               acc))))))
2153
2154(defun arm2-unboxed-reg-for-aset (seg type-keyword result-reg safe constval)
2155  (with-arm-local-vinsn-macros (seg)
2156    (let* ((arch (backend-target-arch *target-backend*))
2157           (is-node (member type-keyword (arch::target-gvector-types arch)))
2158           (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
2159           (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
2160           (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
2161           (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
2162           (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector)))
2163           (result-is-node-gpr (and (eql (hard-regspec-class result-reg)
2164                                         hard-reg-class-gpr)
2165                                    (eql (get-regspec-mode result-reg)
2166                                         hard-reg-class-gpr-mode-node)))
2167           (next-imm-target (available-imm-temp *available-backend-imm-temps*))
2168           (next-fp-target (available-fp-temp *available-backend-fp-temps*)))
2169      (if (or is-node (not result-is-node-gpr))
2170        result-reg
2171        (cond (is-64-bit
2172               (if (eq type-keyword :double-float-vector)
2173                 (let* ((reg (make-unwired-lreg next-fp-target :mode hard-reg-class-fpr-mode-double)))
2174                   (if safe
2175                     (! get-double? reg result-reg)
2176                     (! get-double reg result-reg))
2177                   reg)))
2178              (is-32-bit
2179               ;; Generally better to use a GPR for the :SINGLE-FLOAT-VECTOR
2180               ;; case here.
2181               (if is-signed             
2182                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s32)))
2183                   (if (eq type-keyword :fixnum-vector)
2184                     (progn
2185                       (when safe
2186                         (! trap-unless-fixnum result-reg))
2187                       (! fixnum->signed-natural reg result-reg))
2188                     (! unbox-s32 reg result-reg))
2189                   reg)
2190                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u32)))
2191                   (cond ((eq type-keyword :simple-string)
2192                          (if (characterp constval)
2193                            (arm2-lri seg reg (char-code constval))
2194                            (! unbox-base-char reg result-reg)))
2195                         ((eq type-keyword :single-float-vector)
2196                          (if (typep constval 'single-float)
2197                            (arm2-lri seg reg (single-float-bits constval))
2198                            (progn
2199                              (when safe
2200                                (! trap-unless-single-float result-reg))
2201                              (! single-float-bits reg result-reg))))
2202                         (t
2203                          (if (typep constval '(unsigned-byte 32))
2204                            (arm2-lri seg reg constval)
2205                            (! unbox-u32 reg result-reg))))
2206                   reg)))
2207              (is-16-bit
2208               (if is-signed
2209                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s16)))
2210                   (if (typep constval '(signed-byte 16))
2211                     (arm2-lri seg reg constval)
2212                     (! unbox-s16 reg result-reg))
2213                   reg)
2214                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u16)))
2215                   (if (typep constval '(unsigned-byte 16))
2216                     (arm2-lri seg reg constval)
2217                     (! unbox-u16 reg result-reg))
2218                   reg)))
2219              (is-8-bit
2220               (if is-signed
2221                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-s8)))
2222                   (if (typep constval '(signed-byte 8))
2223                     (arm2-lri seg reg constval)
2224                     (! unbox-s8 reg result-reg))
2225                   reg)
2226                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u8)))
2227                   (if (typep constval '(unsigned-byte 8))
2228                     (arm2-lri seg reg constval)
2229                     (! unbox-u8 reg result-reg))
2230                   reg)))
2231              (t
2232                 (let* ((reg (make-unwired-lreg next-imm-target :mode hard-reg-class-gpr-mode-u8)))
2233                   (unless (typep constval 'bit)
2234                     (! unbox-bit reg result-reg))
2235                   reg)))))))
2236                   
2237     
2238;;; "val-reg" might be boxed, if the vreg requires it to be.
2239(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))
2240  (with-arm-local-vinsn-macros (seg vreg xfer)
2241    (let* ((arch (backend-target-arch *target-backend*))
2242           (is-node (member type-keyword (arch::target-gvector-types arch)))
2243           (is-1-bit (member type-keyword (arch::target-1-bit-ivector-types arch)))
2244           (is-8-bit (member type-keyword (arch::target-8-bit-ivector-types arch)))
2245           (is-16-bit (member type-keyword (arch::target-16-bit-ivector-types arch)))
2246           (is-32-bit (member type-keyword (arch::target-32-bit-ivector-types arch)))
2247           (is-64-bit (member type-keyword (arch::target-64-bit-ivector-types arch)))
2248           (is-signed (member type-keyword '(:signed-8-bit-vector :signed-16-bit-vector :signed-32-bit-vector :signed-64-bit-vector :fixnum-vector))))
2249      (cond ((and is-node node-value-needs-memoization)
2250             (unless (and (eql (hard-regspec-value src) arm::arg_x)
2251                          (eql (hard-regspec-value unscaled-idx) arm::arg_y)
2252                          (eql (hard-regspec-value val-reg) arm::arg_z))
2253               (compiler-bug "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg)))
2254             (! call-subprim-3 val-reg (arm::arm-subprimitive-offset '.SPgvset) src unscaled-idx val-reg))
2255            (is-node
2256             (if (and index-known-fixnum (<= index-known-fixnum
2257                                             (arch::target-max-32-bit-constant-index arch)))
2258               (! misc-set-c-node val-reg src index-known-fixnum)
2259               (with-imm-target () scaled-idx
2260
2261                 (if index-known-fixnum
2262                   (arm2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum *arm2-target-node-shift*)))
2263                   (! scale-node-misc-index scaled-idx unscaled-idx))
2264                 (! misc-set-node val-reg src scaled-idx))))
2265            (t
2266             (cond
2267               (is-64-bit
2268                (with-imm-target (arm::imm0 arm::imm1) scaled-idx
2269                  (if (and index-known-fixnum
2270                           (<= index-known-fixnum
2271                               (arch::target-max-64-bit-constant-index arch)))
2272                    (! misc-set-c-double-float unboxed-val-reg src index-known-fixnum)
2273                    (progn
2274                      (if index-known-fixnum
2275                        (unless unscaled-idx
2276                          (setq unscaled-idx scaled-idx)
2277                          (arm2-absolute-natural seg unscaled-idx nil (ash index-known-fixnum arm::fixnumshift))))
2278                      (! misc-set-double-float unboxed-val-reg src unscaled-idx)))))
2279                 (t
2280                  (with-imm-target (unboxed-val-reg) scaled-idx
2281                    (cond
2282                      (is-32-bit
2283                       (if (and index-known-fixnum
2284                                (<= index-known-fixnum
2285                                    (if (and (eq type-keyword :single-float-vector)
2286                                             (eq (hard-regspec-class unboxed-val-reg)
2287                                                 hard-reg-class-fpr))
2288                                      255
2289                                      (arch::target-max-32-bit-constant-index arch))))
2290                         (if (eq type-keyword :single-float-vector)
2291                           (if (eq (hard-regspec-class unboxed-val-reg)
2292                                   hard-reg-class-fpr)
2293                             (! misc-set-c-single-float unboxed-val-reg src index-known-fixnum)
2294                             (! misc-set-c-u32 unboxed-val-reg src index-known-fixnum))
2295                           (if is-signed
2296                             (! misc-set-c-s32 unboxed-val-reg src index-known-fixnum)
2297                             (! misc-set-c-u32 unboxed-val-reg src index-known-fixnum)))
2298                         (progn
2299                           (if index-known-fixnum
2300                             (arm2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
2301                             (! scale-32bit-misc-index scaled-idx unscaled-idx))
2302                           (if (and (eq type-keyword :single-float-vector)
2303                                    (eql (hard-regspec-class unboxed-val-reg)
2304                                         hard-reg-class-fpr))
2305                             (! misc-set-single-float unboxed-val-reg src scaled-idx)
2306                             (if is-signed
2307                               (! misc-set-s32 unboxed-val-reg src scaled-idx)
2308                               (! misc-set-u32 unboxed-val-reg src scaled-idx))))))
2309                      (is-16-bit
2310                       (if (and index-known-fixnum
2311                                (<= index-known-fixnum
2312                                    (arch::target-max-16-bit-constant-index arch)))
2313                         (if is-signed
2314                           (! misc-set-c-s16 unboxed-val-reg src index-known-fixnum)
2315                           (! misc-set-c-u16 unboxed-val-reg src index-known-fixnum))
2316                         (progn
2317                           (if index-known-fixnum
2318                             (arm2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1)))
2319                             (! scale-16bit-misc-index scaled-idx unscaled-idx))
2320                           (if is-signed
2321                             (! misc-set-s16 unboxed-val-reg src scaled-idx)
2322                             (! misc-set-u16 unboxed-val-reg src scaled-idx)))))
2323                      (is-8-bit
2324                       (if (and index-known-fixnum
2325                                (<= index-known-fixnum
2326                                    (arch::target-max-8-bit-constant-index arch)))
2327                         (if is-signed
2328                           (! misc-set-c-s8 unboxed-val-reg src index-known-fixnum)
2329                           (! misc-set-c-u8  unboxed-val-reg src index-known-fixnum))
2330                         (progn
2331                           (if index-known-fixnum
2332                             (arm2-absolute-natural seg scaled-idx nil (+ (arch::target-misc-data-offset arch) index-known-fixnum))
2333                             (! scale-8bit-misc-index scaled-idx unscaled-idx))
2334                           (if is-signed
2335                             (! misc-set-s8 unboxed-val-reg src scaled-idx)
2336                             (! misc-set-u8 unboxed-val-reg src scaled-idx)))))
2337                      (t
2338                       (unless is-1-bit
2339                         (nx-error "~& unsupported vector type: ~s"
2340                                   type-keyword))
2341                       (if (and index-known-fixnum (<= index-known-fixnum (arch::target-max-1-bit-constant-index arch)))
2342                         (with-imm-target (unboxed-val-reg) word
2343                           (let* ((word-index (ash index-known-fixnum -5))
2344                                  (bit-number (logand index-known-fixnum #x1f)))
2345                             (! misc-ref-c-u32 word src word-index)
2346                             (if constval
2347                               (if (zerop constval)
2348                                 (! set-constant-arm-bit-to-0 word word bit-number)
2349                                 (! set-constant-arm-bit-to-1 word word bit-number))
2350                               (! set-constant-arm-bit-to-variable-value word word unboxed-val-reg bit-number))
2351                             (! misc-set-c-u32 word src word-index)))
2352                         (with-crf-target () crf
2353                           (with-imm-temps () (word-index bit-number temp)
2354                             (unless constval
2355                               (! compare-immediate crf unboxed-val-reg 0))
2356                             (! scale-1bit-misc-index word-index bit-number unscaled-idx)
2357                             (! lri temp 1)
2358                             (! shift-left-variable-word bit-number temp bit-number)
2359                             (! misc-ref-u32 temp src word-index)
2360                             (if constval
2361                               (if (zerop constval)
2362                                 (! u32logandc2 temp temp bit-number)
2363                                 (! u32logior temp temp bit-number))
2364                               (progn
2365                                 (! set-or-clear-bit temp temp bit-number crf)))
2366                             (! misc-set-u32 temp src word-index)))))))))))
2367      (when (and vreg val-reg) (<- val-reg))
2368    (^))))
2369                   
2370
2371(defun arm2-code-coverage-entry (seg note)
2372  (let* ((afunc *arm2-cur-afunc*))
2373    (setf (afunc-bits afunc) (%ilogior (afunc-bits afunc) (ash 1 $fbitccoverage)))
2374    (with-arm-local-vinsn-macros (seg)
2375      (let* ((ccreg ($ arm::temp0)))
2376        (arm2-store-immediate seg note ccreg)
2377        (with-node-temps (ccreg) (zero)
2378          (! lri zero 0)
2379          (! misc-set-c-node zero ccreg 1))))))
2380
2381(defun arm2-vset (seg vreg xfer type-keyword vector index value safe)
2382  (with-arm-local-vinsn-macros (seg)
2383    (let* ((arch (backend-target-arch *target-backend*))
2384           (is-node (member type-keyword (arch::target-gvector-types arch)))
2385           (constval (arm2-constant-value-ok-for-type-keyword type-keyword value))
2386           (needs-memoization (and is-node (arm2-acode-needs-memoization value)))
2387           (index-known-fixnum (acode-fixnum-form-p index)))
2388      (let* ((src ($ arm::arg_x))
2389             (unscaled-idx ($ arm::arg_y))
2390             (result-reg ($ arm::arg_z)))
2391        (cond (needs-memoization
2392               (arm2-three-targeted-reg-forms seg
2393                                              vector src
2394                                              index unscaled-idx
2395                                              value result-reg))
2396              (t
2397               (if (and (not safe) index-known-fixnum)
2398                 (multiple-value-setq (src result-reg unscaled-idx)
2399                   (arm2-two-untargeted-reg-forms seg
2400                                                  vector src
2401                                                  value (arm2-target-reg-for-aset vreg type-keyword)))
2402                 (multiple-value-setq (src unscaled-idx result-reg)
2403                   (arm2-three-untargeted-reg-forms seg
2404                                                    vector src
2405                                                    index unscaled-idx
2406                                                    value (arm2-target-reg-for-aset vreg type-keyword))))))
2407        (when safe
2408          (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)
2409                 (value (if (eql (hard-regspec-class result-reg)
2410                                 hard-reg-class-gpr)
2411                          (hard-regspec-value result-reg))))
2412            (when (and value (logbitp value *available-backend-imm-temps*))
2413              (setq *available-backend-imm-temps* (bitclr value *available-backend-imm-temps*)))
2414            (if (typep safe 'fixnum)
2415              (! trap-unless-typecode= src safe))
2416            (unless index-known-fixnum
2417              (! trap-unless-fixnum unscaled-idx))
2418            (! check-misc-bound unscaled-idx src)))
2419        (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)))))
2420
2421
2422(defun arm2-tail-call-alias (immref sym &optional arglist)
2423  (let ((alias (cdr (assq sym *arm2-tail-call-aliases*))))
2424    (if (and alias (or (null arglist) (eq (+ (length (car arglist)) (length (cadr arglist))) (cdr alias))))
2425      (make-acode (%nx1-operator immediate) (car alias))
2426      immref)))
2427
2428;;; If BODY is essentially an APPLY involving an &rest arg, try to avoid
2429;;; consing it.
2430(defun arm2-eliminate-&rest (body rest key-p auxen rest-values)
2431  (when (and rest (not key-p) (not (cadr auxen)) rest-values)
2432    (when (eq (logand (the fixnum (nx-var-bits rest))
2433                      (logior (ash -1 $vbitspecial)
2434                              (ash 1 $vbitclosed) (ash 1 $vbitsetq) (ash 1 $vbitcloseddownward)))
2435              0)               ; Nothing but simple references
2436      (do* ()
2437           ((not (acode-p body)))
2438        (let* ((op (acode-operator body)))
2439          (if (or (eq op (%nx1-operator lexical-function-call))
2440                  (eq op (%nx1-operator call)))
2441            (destructuring-bind (fn-form (stack-args reg-args) &optional spread-p) (%cdr body)
2442               (unless (and (eq spread-p t)
2443                           (eq (arm2-lexical-reference-p (%car reg-args)) rest))
2444                (return nil))
2445              (flet ((independent-of-all-values (form)       
2446                       (setq form (acode-unwrapped-form-value form))
2447                       (or (arm-constant-form-p form)
2448                           (let* ((lexref (arm2-lexical-reference-p form)))
2449                             (and lexref 
2450                                  (neq lexref rest)
2451                                  (dolist (val rest-values t)
2452                                    (unless (arm2-var-not-set-by-form-p lexref val)
2453                                      (return))))))))
2454                (unless (or (eq op (%nx1-operator lexical-function-call))
2455                            (independent-of-all-values fn-form))
2456                  (return nil))
2457                (if (dolist (s stack-args t)
2458                          (unless (independent-of-all-values s)
2459                            (return nil)))
2460                  (let* ((arglist (append stack-args rest-values)))
2461                    (return
2462                     (make-acode op 
2463                                 fn-form 
2464                                 (if (<= (length arglist) $numarmargregs)
2465                                   (list nil (reverse arglist))
2466                                   (list (butlast arglist $numarmargregs)
2467                                         (reverse (last arglist $numarmargregs))))
2468                                 nil)))
2469                  (return nil))))
2470            (if (eq op (%nx1-operator local-block))
2471              (setq body (%cadr body))
2472              (if (and (eq op (%nx1-operator if))
2473                       (eq (arm2-lexical-reference-p (%cadr body)) rest))
2474                (setq body (%caddr body))
2475                (return nil)))))))))
2476
2477(defun arm2-call-fn (seg vreg xfer fn arglist spread-p)
2478  (with-arm-local-vinsn-macros (seg vreg xfer)
2479    (when spread-p
2480      (destructuring-bind (stack-args reg-args) arglist
2481        (when (and (null (cdr reg-args))
2482                   (nx-null (acode-unwrapped-form-value (car reg-args))))
2483          (setq spread-p nil)
2484          (let* ((nargs (length stack-args)))
2485            (declare (fixnum nargs))
2486            (if (<= nargs $numarmargregs)
2487              (setq arglist (list nil (reverse stack-args)))
2488              (setq arglist (list (butlast stack-args $numarmargregs) (reverse (last stack-args $numarmargregs)))))))))
2489    (let* ((lexref (arm2-lexical-reference-p fn))
2490           (simple-case (or (fixnump fn)
2491                            (typep fn 'lreg)
2492                            (arm2-immediate-function-p fn)
2493                            (and 
2494                             lexref
2495                             (not spread-p)
2496                             (flet ((all-simple (args)
2497                                      (dolist (arg args t)
2498                                        (when (and arg (not (arm2-var-not-set-by-form-p lexref arg)))
2499                                          (return)))))
2500                               (and (all-simple (car arglist))
2501                                    (all-simple (cadr arglist))
2502                                    (setq fn (var-ea lexref)))))))
2503           (cstack *arm2-cstack*)
2504           (top *arm2-top-vstack-lcell*)
2505           (vstack *arm2-vstack*))
2506      (setq xfer (or xfer 0))
2507      (when (and (eq xfer $backend-return)
2508                 (eq 0 *arm2-undo-count*)
2509                 (acode-p fn)
2510                 (eq (acode-operator fn) (%nx1-operator immediate))
2511                 (symbolp (cadr fn)))
2512        (setq fn (arm2-tail-call-alias fn (%cadr fn) arglist)))
2513     
2514      (if (and (eq xfer $backend-return) (not (arm2-tailcallok xfer)))
2515        (progn
2516          (arm2-call-fn seg vreg $backend-mvpass fn arglist spread-p)
2517          (arm2-set-vstack (%i+ (if simple-case 0 *arm2-target-node-size*) vstack))
2518          (setq  *arm2-cstack* cstack)
2519          (let ((*arm2-returning-values* t)) (arm2-do-return seg)))
2520        (let* ((mv-p (arm2-mv-p xfer)))
2521          (unless simple-case
2522            (arm2-vpush-register seg (arm2-one-untargeted-reg-form seg fn arm::arg_z))
2523            (setq fn (arm2-vloc-ea vstack)))
2524          (arm2-invoke-fn seg fn (arm2-arglist seg arglist) spread-p xfer)
2525          (if (and (logbitp $backend-mvpass-bit xfer)
2526                   (not simple-case))
2527            (progn
2528              (! save-values)
2529              (! vstack-discard 1)
2530              (arm2-set-nargs seg 0)
2531              (! recover-values))
2532            (unless (or mv-p simple-case)
2533              (! vstack-discard 1)))
2534          (arm2-set-vstack vstack)
2535          (setq *arm2-top-vstack-lcell* top)
2536          (setq *arm2-cstack* cstack)
2537          (when (or (logbitp $backend-mvpass-bit xfer) (not mv-p))
2538            (<- arm::arg_z)
2539            (arm2-branch seg (logand (lognot $backend-mvpass-mask) xfer) vreg))))
2540      nil)))
2541
2542(defun arm2-restore-full-lisp-context (seg)
2543  (with-arm-local-vinsn-macros (seg)
2544    (! restore-full-lisp-context)))
2545
2546(defun arm2-call-symbol (seg jump-p)
2547  ; fname contains a symbol; we can either call it via
2548  ; a call to .SPjmpsym or expand the instructions inline.
2549  ; Since the branches are unconditional, the call doesn't
2550  ; cost much, but doing the instructions inline would give
2551  ; an instruction scheduler some opportunities to improve
2552  ; performance, so this isn't a strict time/speed tradeoff.
2553  ; This should probably dispatch on something other than
2554  ; *arm2-open-code-inline*, since that does imply a time/speed
2555  ; tradeoff.
2556  (with-arm-local-vinsn-macros (seg)
2557    (if *arm2-optimize-for-space*
2558      (if jump-p
2559        (! jump-known-symbol-ool)
2560        (! call-known-symbol-ool))
2561      (if jump-p
2562        (! jump-known-symbol)
2563        (! call-known-symbol arm::arg_z)))))
2564
2565;;; Nargs = nil -> multiple-value case.
2566(defun arm2-invoke-fn (seg fn nargs spread-p xfer)
2567  (with-arm-local-vinsn-macros (seg)
2568    (let* ((f-op (acode-unwrapped-form-value fn))
2569           (immp (and (consp f-op)
2570                      (eq (%car f-op) (%nx1-operator immediate))))
2571           (symp (and immp (symbolp (%cadr f-op))))
2572           (label-p (and (fixnump fn) 
2573                         (locally (declare (fixnum fn))
2574                           (and (= fn -1) (- fn)))))
2575           (tail-p (eq xfer $backend-return))
2576           (func (if (consp f-op) (%cadr f-op)))
2577           (a-reg nil)
2578           (lfunp (and (acode-p f-op) 
2579                       (eq (acode-operator f-op) (%nx1-operator simple-function))))
2580           (expression-p (or (typep fn 'lreg) (and (fixnump fn) (not label-p))))
2581           (callable (or symp lfunp label-p))
2582           (destreg (if symp ($ arm::fname) (if lfunp ($ arm::nfn) (unless label-p ($ arm::nfn)))))
2583           (known-fixed-nargs nil)
2584           (label (when label-p
2585                    (if (and *arm2-fixed-args-label*
2586                             (eql nargs *arm2-fixed-nargs*)
2587                             (not spread-p)
2588                             (not (arm2-mvpass-p xfer)))
2589                      (progn
2590                        (setq known-fixed-nargs t)
2591                        (if tail-p
2592                          *arm2-fixed-args-tail-label*
2593                          *arm2-fixed-args-label*))
2594                      1))))
2595      (when expression-p
2596        ;;Have to do this before spread args, since might be vsp-relative.
2597        (if nargs
2598          (arm2-do-lexical-reference seg destreg fn)
2599          (arm2-copy-register seg destreg fn)))
2600      (if (or symp lfunp)
2601        (setq func (if symp (arm2-symbol-entry-locative func)
2602                     (arm2-afunc-lfun-ref func))
2603              a-reg (arm2-register-constant-p func)))
2604      (when tail-p
2605        #-no-compiler-bugs
2606        (unless (or immp symp lfunp (typep fn 'lreg) (fixnump fn)) (compiler-bug "Well, well, well.  How could this have happened ?"))
2607        (when a-reg
2608          (arm2-copy-register seg destreg a-reg))
2609        (unless spread-p
2610          (arm2-restore-nvrs seg (null nargs))
2611          (arm2-restore-non-volatile-fprs seg)))
2612      (if spread-p
2613        (progn
2614          (arm2-set-nargs seg (%i- nargs 1))
2615          (if (eq spread-p 0)
2616            (! spread-lexpr)
2617            (! spread-list))
2618          (arm2-restore-nvrs seg nil)
2619          (arm2-restore-non-volatile-fprs seg))
2620        (if nargs
2621          (unless known-fixed-nargs (arm2-set-nargs seg nargs))
2622          (! pop-argument-registers)))
2623      (if callable
2624        (if (not tail-p)
2625          (if (arm2-mvpass-p xfer)
2626            (let* ((call-reg (if symp ($ arm::fname) ($ arm::nfn))))
2627              (if label-p
2628                (arm2-copy-register seg call-reg ($ arm::fn))
2629                (if a-reg
2630                  (arm2-copy-register seg call-reg  a-reg)
2631                  (arm2-store-immediate seg func call-reg)))
2632              (if symp
2633                (! pass-multiple-values-symbol)
2634                (! pass-multiple-values)))
2635            (progn 
2636              (if label-p
2637                (progn
2638                  (arm2-copy-register seg ($ arm::nfn) ($  arm::fn))
2639                  (! call-label (aref *backend-labels* label)))
2640                (progn
2641                  (if a-reg
2642                    (arm2-copy-register seg destreg a-reg)
2643                    (arm2-store-immediate seg func destreg))
2644                  (if symp
2645                    (arm2-call-symbol seg nil)
2646                    (! call-known-function))))))
2647          (progn
2648            (arm2-unwind-stack seg xfer 0 0 #x7fffff)
2649            (if (and (not spread-p) nargs (%i<= nargs $numarmargregs))
2650              (progn
2651                (if label-p
2652                  (unless known-fixed-nargs
2653                    (arm2-copy-register seg arm::nfn arm::fn)))
2654                (unless (or label-p a-reg) (arm2-store-immediate seg func destreg))
2655                (unless known-fixed-nargs
2656                  (arm2-restore-full-lisp-context seg))
2657                (if label-p
2658                  (! jump (aref *backend-labels* label))
2659                  (progn
2660                    (if symp
2661                      (arm2-call-symbol seg t)
2662                      (! jump-known-function)))))
2663              (progn
2664                (if label-p
2665                  (arm2-copy-register seg arm::nfn arm::fn)
2666                  (unless a-reg (arm2-store-immediate seg func destreg)))
2667                (cond ((or spread-p (null nargs))
2668                       (if symp
2669                         (! tail-call-sym-gen)
2670                         (! tail-call-fn-gen)))
2671                      ((%i> nargs $numarmargregs)
2672                       (if symp
2673                         (! tail-call-sym-slide)
2674                         (! tail-call-fn-slide)))
2675                      (t
2676                       (! restore-full-lisp-context)
2677                       (if symp
2678                         (! jump-known-symbol)
2679                         (! jump-known-function))))))))
2680        ;; The general (funcall) case: we don't know (at compile-time)
2681        ;; for sure whether we've got a symbol or a (local, constant)
2682        ;; function.
2683        (progn
2684          (unless (or (fixnump fn) (typep fn 'lreg))
2685            (arm2-one-targeted-reg-form seg fn destreg))
2686          (if (not tail-p)
2687            (if (arm2-mvpass-p xfer)
2688              (! pass-multiple-values)
2689              (! funcall))                 
2690            (cond ((or (null nargs) spread-p)
2691                   (! tail-funcall-gen))
2692                  ((%i> nargs $numarmargregs)
2693                   (! tail-funcall-slide))
2694                  (t
2695                   (! tail-funcall-vsp)))))))
2696    nil))
2697
2698(defun arm2-seq-fbind (seg vreg xfer vars afuncs body p2decls)
2699  (let* ((old-stack (arm2-encode-stack))
2700         (copy afuncs)
2701         (func nil))
2702    (with-arm-p2-declarations p2decls 
2703      (dolist (var vars) 
2704        (when (neq 0 (afunc-fn-refcount (setq func (pop afuncs))))
2705          (arm2-seq-bind-var seg var (nx1-afunc-ref func))))
2706      (arm2-undo-body seg vreg xfer body old-stack)
2707      (dolist (var vars)
2708        (when (neq 0 (afunc-fn-refcount (setq func (pop copy))))
2709          (arm2-close-var seg var))))))
2710
2711(defun arm2-make-closure (seg afunc downward-p)
2712  (with-arm-local-vinsn-macros (seg)
2713    (flet ((var-to-reg (var target)
2714             (let* ((ea (var-ea (var-bits var))))
2715               (if ea
2716                 (arm2-addrspec-to-reg seg (arm2-ea-open ea) target)
2717                 (! load-nil target))
2718               target))
2719           (set-some-cells (dest cellno c0 c1 c2 c3)
2720             (declare (fixnum cellno))
2721             (! misc-set-c-node c0 dest cellno)
2722             (incf cellno)
2723             (when c1
2724               (! misc-set-c-node c1 dest cellno)
2725               (incf cellno)
2726               (when c2
2727                 (! misc-set-c-node c2 dest cellno)
2728                 (incf cellno)
2729                 (when c3
2730                   (! misc-set-c-node c3 dest cellno)
2731                   (incf cellno))))
2732             cellno))
2733      (let* ((inherited-vars (afunc-inherited-vars afunc))
2734             (arch (backend-target-arch *target-backend*))
2735             (dest ($ arm::arg_z))
2736             (vsize (+ (length inherited-vars) 
2737                       3                ; entrypoint,%closure-code%, afunc
2738                       2)))             ; name, lfun-bits
2739        (declare (list inherited-vars))
2740        (if downward-p
2741          (progn
2742            (let* ((*arm2-vstack* *arm2-vstack*)
2743                   (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*))
2744              (arm2-lri seg arm::arg_x (ash (nx-lookup-target-uvector-subtag :function) *arm2-target-fixnum-shift*))
2745              (arm2-lri seg arm::temp0 0)
2746              (! %closure-code% arm::arg_y)
2747              (arm2-store-immediate seg (arm2-afunc-lfun-ref afunc) arm::arg_z)
2748              (arm2-vpush-register-arg seg arm::arg_x)
2749              (arm2-vpush-register-arg seg arm::temp0)
2750              (arm2-vpush-register-arg seg arm::arg_y)
2751              (arm2-vpush-register-arg seg arm::arg_z)
2752              ;; Could be smarter about memory traffic here.
2753              (dolist (v inherited-vars)
2754                (arm2-vpush-register-arg seg (var-to-reg v arm::arg_z)))
2755              (! load-nil arm::arg_z)
2756              (arm2-vpush-register-arg seg arm::arg_z)
2757              (arm2-lri seg arm::arg_z (ash (ash 1 $lfbits-trampoline-bit) *arm2-target-fixnum-shift*))
2758              (arm2-vpush-register-arg seg arm::arg_z)
2759              (arm2-set-nargs seg (1+ vsize)) ; account for subtag
2760              (! make-stack-closure))
2761            (arm2-open-undo $undostkblk))
2762          (let* ((cell 1))
2763            (declare (fixnum cell))
2764            (progn
2765              (arm2-lri seg
2766                        arm::imm0
2767                        (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function)))
2768              (! %alloc-misc-fixed dest arm::imm0 (ash vsize (arch::target-word-shift arch)))
2769              )
2770            (! %closure-code% arm::arg_x)
2771            (! %codevector-entry arm::lr arm::arg_x)
2772            (! misc-set-c-node arm::lr dest 0)
2773            (arm2-store-immediate seg (arm2-afunc-lfun-ref afunc) arm::arg_y)
2774            (with-node-temps (arm::arg_z) (t0 t1 t2 t3)
2775              (do* ((ccode arm::arg_x nil)
2776                    (func arm::arg_y nil))
2777                   ((null inherited-vars))
2778                (let* ((t0r (or ccode (if inherited-vars (var-to-reg (pop inherited-vars) t0))))
2779                       (t1r (or func (if inherited-vars (var-to-reg (pop inherited-vars) t1))))
2780                       (t2r (if inherited-vars (var-to-reg (pop inherited-vars) t2)))
2781                       (t3r (if inherited-vars (var-to-reg (pop inherited-vars) t3))))
2782                  (setq cell (set-some-cells dest cell t0r t1r t2r t3r)))))
2783            (arm2-lri seg arm::arg_y (ash (ash 1 $lfbits-trampoline-bit) *arm2-target-fixnum-shift*))
2784            (! load-nil arm::arg_x)
2785            (! misc-set-c-node arm::arg_x dest cell)
2786            (! misc-set-c-node arm::arg_y dest (1+ cell))))
2787        dest))))
2788       
2789(defun arm2-symbol-entry-locative (sym)
2790  (setq sym (require-type sym 'symbol))
2791  (when (eq sym '%call-next-method-with-args)
2792    (setf (afunc-bits *arm2-cur-afunc*)
2793          (%ilogior (%ilsl $fbitnextmethargsp 1) (afunc-bits *arm2-cur-afunc*))))
2794  (or (assq sym *arm2-fcells*)
2795      (let ((new (list sym)))
2796        (push new *arm2-fcells*)
2797        new)))
2798
2799(defun arm2-symbol-value-cell (sym)
2800  (setq sym (require-type sym 'symbol))
2801  (or (assq sym *arm2-vcells*)
2802      (let ((new (list sym)))
2803        (push new *arm2-vcells*)
2804        (ensure-binding-index sym)
2805        new)))
2806
2807
2808(defun arm2-symbol-locative-p (imm)
2809  (and (consp imm)
2810       (or (memq imm *arm2-vcells*)
2811           (memq imm *arm2-fcells*))))
2812
2813
2814
2815
2816(defun arm2-immediate-function-p (f)
2817  (setq f (acode-unwrapped-form-value f))
2818  (and (acode-p f)
2819       (or (eq (%car f) (%nx1-operator immediate))
2820           (eq (%car f) (%nx1-operator simple-function)))))
2821
2822(defun arm-constant-form-p (form)
2823  (setq form (nx-untyped-form form))
2824  (if form
2825    (or (nx-null form)
2826        (nx-t form)
2827        (and (consp form)
2828             (or (eq (acode-operator form) (%nx1-operator immediate))
2829                 (eq (acode-operator form) (%nx1-operator fixnum))
2830                 (eq (acode-operator form) (%nx1-operator simple-function)))))))
2831
2832
2833 
2834(defun arm2-integer-constant-p (form mode)
2835  (let* ((val 
2836         (or (acode-fixnum-form-p (setq form (acode-unwrapped-form form)))
2837             (and (acode-p form)
2838                  (eq (acode-operator form) (%nx1-operator immediate))
2839                  (setq form (%cadr form))
2840                  (if (typep form 'integer)
2841                    form)))))
2842    (and val (%typep val (mode-specifier-type mode)) val)))
2843
2844
2845(defun arm-side-effect-free-form-p (form)
2846  (when (consp (setq form (acode-unwrapped-form-value form)))
2847    (or (arm-constant-form-p form)
2848        ;(eq (acode-operator form) (%nx1-operator bound-special-ref))
2849        (if (eq (acode-operator form) (%nx1-operator lexical-reference))
2850          (not (%ilogbitp $vbitsetq (nx-var-bits (%cadr form))))))))
2851
2852(defun arm2-formlist (seg stkargs &optional revregargs)
2853  (with-arm-local-vinsn-macros (seg) 
2854    (let* ((nregs (length revregargs))
2855           (n nregs))
2856      (declare (fixnum n))
2857      (dolist (arg stkargs)
2858        (let* ((reg (arm2-one-untargeted-reg-form seg arg arm::arg_z)))
2859          (arm2-vpush-register-arg seg reg)
2860          (incf n)))
2861      (when revregargs
2862        (let* ((zform (%car revregargs))
2863               (yform (%cadr revregargs))
2864               (xform (%caddr revregargs)))
2865          (if (eq 3 nregs)
2866            (arm2-three-targeted-reg-forms seg xform ($ arm::arg_x) yform ($ arm::arg_y) zform ($ arm::arg_z))
2867            (if (eq 2 nregs)
2868              (arm2-two-targeted-reg-forms seg yform ($ arm::arg_y) zform ($ arm::arg_z))
2869              (arm2-one-targeted-reg-form seg zform ($ arm::arg_z))))))
2870      n)))
2871
2872(defun arm2-arglist (seg args)
2873  (arm2-formlist seg (car args) (cadr args)))
2874
2875
2876
2877
2878
2879(defun arm2-unboxed-integer-arg-to-reg (seg form immreg &optional ffi-arg-type)
2880  (let* ((mode (case ffi-arg-type
2881                 ((nil) :natural)
2882                 (:signed-byte :s8)
2883                 (:unsigned-byte :u8)
2884                 (:signed-halfword :s16)
2885                 (:unsigned-halfword :u16)
2886                 (:signed-fullword :s32)
2887                 (:unsigned-fullword :u32)
2888                 (:unsigned-doubleword :u64)
2889                 (:signed-doubleword :s64)))
2890         (modeval (gpr-mode-name-value mode)))
2891    (with-arm-local-vinsn-macros (seg)
2892      (let* ((value (arm2-integer-constant-p form mode)))
2893        (if value
2894            (progn
2895              (unless (typep immreg 'lreg)
2896                (setq immreg (make-unwired-lreg immreg :mode modeval)))
2897              (arm2-lri seg immreg value)
2898              immreg)
2899          (progn 
2900            (arm2-one-targeted-reg-form seg form (make-wired-lreg arm::imm0 :mode modeval))))))))
2901
2902
2903(defun arm2-macptr-arg-to-reg (seg form address-reg) 
2904  (arm2-one-targeted-reg-form seg
2905                              form 
2906                              address-reg))
2907
2908(defun arm2-push-reg-for-form (seg form suggested &optional targeted)
2909  (let* ((reg (if (and (node-reg-p suggested)
2910                         (nx2-acode-call-p form))     ;probably ...
2911                (arm2-one-targeted-reg-form seg form  arm::arg_z)
2912                (if targeted
2913                  (arm2-one-targeted-reg-form seg form suggested)
2914                  (arm2-one-untargeted-reg-form seg form suggested)))))
2915    (arm2-push-register seg reg)))
2916
2917(defun arm2-one-lreg-form (seg form lreg)
2918  (let ((is-float (= (hard-regspec-class lreg) hard-reg-class-fpr)))
2919    (if is-float
2920      (arm2-form-float seg lreg nil form)
2921      (arm2-form seg lreg nil form))
2922    lreg))
2923
2924(defun arm2-one-targeted-reg-form (seg form reg)
2925  (arm2-one-lreg-form seg form reg))
2926
2927(defun arm2-one-untargeted-lreg-form (seg form reg)
2928  (arm2-one-lreg-form seg form (if (typep reg 'lreg) reg (make-unwired-lreg reg))))
2929
2930(defun same-arm-reg-p (x y)
2931  (and (eq (hard-regspec-value x) (hard-regspec-value y))
2932       (let* ((class (hard-regspec-class x)))
2933         (and (eq class (hard-regspec-class y))
2934              (or (not (eql class hard-reg-class-fpr))
2935                  (eq (%get-regspec-mode x)
2936                      (%get-regspec-mode y)))))))
2937
2938;;; If REG is a node reg, add it to the bitmask.
2939(defun arm2-restrict-node-target (reg mask)
2940  (if (node-reg-p reg)
2941    (logior mask (ash 1 (hard-regspec-value reg)))
2942    mask))
2943
2944;;; If suggested reg is a node reg that contains a stack location,
2945;;; try to use some other node temp.
2946(defun arm2-try-non-conflicting-reg (suggested reserved)
2947  (let* ((mask *arm2-gpr-locations-valid-mask*))
2948    (or (when (and (node-reg-p suggested)
2949                   (logbitp (hard-regspec-value suggested) mask))
2950          (setq mask (logior mask reserved))
2951          (%available-node-temp (logand *available-backend-node-temps*
2952                                        (lognot mask))))
2953        suggested)))
2954
2955(defun arm2-one-untargeted-reg-form (seg form suggested &optional (reserved 0))
2956  (or (arm2-reg-for-form form suggested)
2957      (if (and (acode-p form)
2958               (eq (acode-operator form) (%nx1-operator %current-tcr)))
2959        arm::rcontext
2960        (if (node-reg-p suggested)
2961          (arm2-one-untargeted-lreg-form seg form (arm2-try-non-conflicting-reg suggested reserved))
2962          (arm2-one-untargeted-lreg-form seg form suggested)))))
2963             
2964
2965(defun arm2-push-register (seg areg)
2966  (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr))
2967         (a-double (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-double)))
2968         (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node)))
2969         vinsn)
2970    (with-arm-local-vinsn-macros (seg)
2971      (if a-node
2972        (setq vinsn (arm2-vpush-register seg areg :node-temp))
2973        (progn
2974          (setq vinsn
2975                (if a-float
2976                  (if a-double
2977                    (! temp-push-double-float areg)
2978                    (! temp-push-single-float areg))
2979                  (! temp-push-unboxed-word areg)))
2980          (arm2-open-undo $undostkblk)))
2981      vinsn)))
2982
2983(defun arm2-pop-register (seg areg)
2984  (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr))
2985         (a-double (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-double)))
2986         (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node)))
2987         vinsn)
2988    (with-arm-local-vinsn-macros (seg)
2989      (if a-node
2990        (setq vinsn (arm2-vpop-register seg areg))
2991        (progn
2992          (setq vinsn
2993                (if a-float
2994                  (if a-double
2995                    (! temp-pop-double-float areg)
2996                    (! temp-pop-single-float areg))
2997                  (! temp-pop-unboxed-word areg)))
2998          (arm2-close-undo)))
2999      vinsn)))
3000
3001(defun arm2-acc-reg-for (reg)
3002  (with-arm-local-vinsn-macros (seg)
3003    (if (and (eql (hard-regspec-class reg) hard-reg-class-gpr)
3004             (eql (get-regspec-mode reg) hard-reg-class-gpr-mode-node))
3005      ($ arm::arg_z)
3006      reg)))
3007
3008;;; The compiler often generates superfluous pushes & pops.  Try to
3009;;; eliminate them.
3010;;; It's easier to elide pushes and pops to the SP.
3011(defun arm2-elide-pushes (seg push-vinsn pop-vinsn)
3012  (with-arm-local-vinsn-macros (seg)
3013    (let* ((pushed-reg (svref (vinsn-variable-parts push-vinsn) 0))
3014           (popped-reg (svref (vinsn-variable-parts pop-vinsn) 0))
3015           (same-reg (eq (hard-regspec-value pushed-reg)
3016                         (hard-regspec-value popped-reg)))
3017           (sp-p (vinsn-attribute-p push-vinsn :csp)))
3018      (when sp-p               ; vsp case is harder.
3019        (unless (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :csp :discard)
3020          (let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p
3021                                     push-vinsn pop-vinsn pushed-reg))
3022                 (popped-reg-is-set (if same-reg
3023                                      pushed-reg-is-set
3024                                      (vinsn-sequence-sets-reg-p
3025                                       push-vinsn pop-vinsn popped-reg))))
3026            (cond
3027              ((not (and pushed-reg-is-set popped-reg-is-set))
3028               (unless same-reg
3029                 (let* ((copy (if (eq (hard-regspec-class pushed-reg)
3030                                      hard-reg-class-fpr)
3031                                (if (eql (get-regspec-mode pushed-reg)
3032                                         hard-reg-class-fpr-mode-single)
3033                                  (! single-to-single popped-reg pushed-reg)
3034                                  (! double-to-double popped-reg pushed-reg))
3035                                (! copy-gpr popped-reg pushed-reg))))
3036                   (remove-dll-node copy)
3037                   (if pushed-reg-is-set
3038                     (insert-dll-node-after copy push-vinsn)
3039                     (insert-dll-node-before copy push-vinsn))))
3040               (elide-vinsn push-vinsn)
3041               (elide-vinsn pop-vinsn))
3042              ((and (eql (hard-regspec-class pushed-reg) hard-reg-class-fpr)
3043                    (eql (get-regspec-mode pushed-reg)
3044                         hard-reg-class-fpr-mode-double))
3045               ;; If we're pushing a double-float register that gets
3046               ;; set by the intervening vinsns, try to copy it to and
3047               ;; from a free FPR instead.
3048               (multiple-value-bind (used-gprs used-fprs)
3049                   (regs-set-in-vinsn-sequence push-vinsn pop-vinsn)
3050                 (declare (ignore used-gprs))
3051                 ;; We have 16 non-volatile single-floats or 8
3052                 ;; non-volatile double-floats
3053                 (let* ((nfprs 7)
3054                        (free-fpr
3055                         (dotimes (r nfprs nil)
3056                           (unless (logtest (target-fpr-mask r :double-float)
3057                                            used-fprs)
3058                             (return r)))))
3059                   (when free-fpr
3060                     (let* ((reg ($ free-fpr :class :fpr :mode :double-float))
3061                            (save (! double-to-double reg pushed-reg))
3062                            (restore (! double-to-double 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))