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

Last change on this file since 15085 was 15085, checked in by gb, 9 years ago

Yet another typo in ARM2-FOUR-UNTARGETED-REG-FORMS (need to set ADEST
if we might have pushed/popped AREG.)

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