source: branches/arm/compiler/ARM/arm2.lisp @ 13858

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

arm2.lisp: 32-bit case of ARM2-VREF1 wasn't parenthesized right, so we did both

the constant- and variable-index case.

arm-vinsns.lisp: lots of bugs in SAVE-LEXPR-ARGREGS
arm-pred.lisp: in EQUAL, compare to NIL, not 'NUL.
l1-clos-boot.lisp: more ARM conditionalization.
arm-spentry.s: use the right register in _SPbind.

Implement _SPnthrowvalues, fix in _SPnthrow1value.
Try to add uuo_debug_trap() to subprims that still aren't implemented.

Currently crashes in code called by ENSURE-METHOD, possibly on the first
DEFMETHOD.

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