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

Last change on this file since 13789 was 13789, checked in by gb, 11 years ago

Lots of (mostly small) changes.

File size: 368.5 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2010 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(eval-when (:compile-toplevel :execute)
20  (require "NXENV")
21  (require "ARMENV"))
22
23(eval-when (:load-toplevel :execute :compile-toplevel)
24  (require "ARM-BACKEND"))
25
26(defparameter *arm2-debug-mask* 0)
27(defconstant arm2-debug-verbose-bit 0)
28(defconstant arm2-debug-vinsns-bit 1)
29(defconstant arm2-debug-lcells-bit 2)
30(defparameter *arm2-target-lcell-size* 0)
31(defparameter *arm2-target-node-size* 0)
32(defparameter *arm2-target-fixnum-shift* 0)
33(defparameter *arm2-target-node-shift* 0)
34(defparameter *arm2-target-bits-in-word* 0)
35(defparameter *arm2-half-fixnum-type* '(signed-byte 29))
36(defparameter *arm2-target-half-fixnum-type* nil)
37
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-ne t))
307    (:GT (values arm::arm-cond-gt t))
308    (:LE (values arm::arm-cond-le t))
309    (:LT (values arm::arm-cond-lt t))
310    (:GE (values arm::arm-cond-ge t))))
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                       2                ; %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              (! %closure-code% arm::arg_y)
2463              (arm2-store-immediate seg (arm2-afunc-lfun-ref afunc) arm::arg_z)
2464              (arm2-vpush-register-arg seg arm::arg_x)
2465              (arm2-vpush-register-arg seg arm::arg_y)
2466              (arm2-vpush-register-arg seg arm::arg_z)
2467                                        ; Could be smarter about memory traffic here.
2468              (dolist (v inherited-vars)
2469                (arm2-vpush-register-arg seg (var-to-reg v arm::arg_z)))
2470              (! load-nil arm::arg_z)
2471              (arm2-vpush-register-arg seg arm::arg_z)
2472              (arm2-lri seg arm::arg_z (ash (ash 1 $lfbits-trampoline-bit) *arm2-target-fixnum-shift*))
2473              (arm2-vpush-register-arg seg arm::arg_z)
2474              (arm2-set-nargs seg (1+ vsize)) ; account for subtag
2475              (! make-stack-gvector))
2476            (arm2-open-undo $undostkblk))
2477          (let* ((cell 0))
2478            (declare (fixnum cell))
2479            (progn
2480              (arm2-lri seg
2481                        arm::imm0
2482                        (arch::make-vheader vsize (nx-lookup-target-uvector-subtag :function)))
2483              (! %alloc-misc-fixed dest arm::imm0 (ash vsize (arch::target-word-shift arch)))
2484              )       
2485            (! %closure-code% arm::arg_x)
2486            (arm2-store-immediate seg (arm2-afunc-lfun-ref afunc) arm::arg_y)
2487            (with-node-temps (arm::arg_z) (t0 t1 t2 t3)
2488              (do* ((ccode arm::arg_x nil)
2489                    (func arm::arg_y nil))
2490                   ((null inherited-vars))
2491                (let* ((t0r (or ccode (if inherited-vars (var-to-reg (pop inherited-vars) t0))))
2492                       (t1r (or func (if inherited-vars (var-to-reg (pop inherited-vars) t1))))
2493                       (t2r (if inherited-vars (var-to-reg (pop inherited-vars) t2)))
2494                       (t3r (if inherited-vars (var-to-reg (pop inherited-vars) t3))))
2495                  (setq cell (set-some-cells dest cell t0r t1r t2r t3r)))))
2496            (arm2-lri seg arm::arg_y (ash (ash 1 $lfbits-trampoline-bit) *arm2-target-fixnum-shift*))
2497            (! load-nil arm::arg_x)
2498            (! misc-set-c-node arm::arg_x dest cell)
2499            (! misc-set-c-node arm::arg_y dest (1+ cell))))
2500        dest))))
2501       
2502(defun arm2-symbol-entry-locative (sym)
2503  (setq sym (require-type sym 'symbol))
2504  (when (eq sym '%call-next-method-with-args)
2505    (setf (afunc-bits *arm2-cur-afunc*)
2506          (%ilogior (%ilsl $fbitnextmethargsp 1) (afunc-bits *arm2-cur-afunc*))))
2507  (or (assq sym *arm2-fcells*)
2508      (let ((new (list sym)))
2509        (push new *arm2-fcells*)
2510        new)))
2511
2512(defun arm2-symbol-value-cell (sym)
2513  (setq sym (require-type sym 'symbol))
2514  (or (assq sym *arm2-vcells*)
2515      (let ((new (list sym)))
2516        (push new *arm2-vcells*)
2517        (ensure-binding-index sym)
2518        new)))
2519
2520
2521(defun arm2-symbol-locative-p (imm)
2522  (and (consp imm)
2523       (or (memq imm *arm2-vcells*)
2524           (memq imm *arm2-fcells*))))
2525
2526
2527
2528
2529(defun arm2-immediate-function-p (f)
2530  (setq f (acode-unwrapped-form-value f))
2531  (and (acode-p f)
2532       (or (eq (%car f) (%nx1-operator immediate))
2533           (eq (%car f) (%nx1-operator simple-function)))))
2534
2535(defun arm-constant-form-p (form)
2536  (setq form (nx-untyped-form form))
2537  (if form
2538    (or (nx-null form)
2539        (nx-t form)
2540        (and (consp form)
2541             (or (eq (acode-operator form) (%nx1-operator immediate))
2542                 (eq (acode-operator form) (%nx1-operator fixnum))
2543                 (eq (acode-operator form) (%nx1-operator simple-function)))))))
2544
2545
2546 
2547(defun arm2-integer-constant-p (form mode)
2548  (let* ((val 
2549         (or (acode-fixnum-form-p (setq form (acode-unwrapped-form form)))
2550             (and (acode-p form)
2551                  (eq (acode-operator form) (%nx1-operator immediate))
2552                  (setq form (%cadr form))
2553                  (if (typep form 'integer)
2554                    form)))))
2555    (and val (%typep val (mode-specifier-type mode)) val)))
2556
2557
2558(defun arm-side-effect-free-form-p (form)
2559  (when (consp (setq form (acode-unwrapped-form-value form)))
2560    (or (arm-constant-form-p form)
2561        ;(eq (acode-operator form) (%nx1-operator bound-special-ref))
2562        (if (eq (acode-operator form) (%nx1-operator lexical-reference))
2563          (not (%ilogbitp $vbitsetq (nx-var-bits (%cadr form))))))))
2564
2565(defun arm2-formlist (seg stkargs &optional revregargs)
2566  (with-arm-local-vinsn-macros (seg) 
2567    (let* ((nregs (length revregargs))
2568           (n nregs))
2569      (declare (fixnum n))
2570      (dolist (arg stkargs)
2571        (let* ((reg (arm2-one-untargeted-reg-form seg arg arm::arg_z)))
2572          (arm2-vpush-register-arg seg reg)
2573          (incf n)))
2574      (when revregargs
2575        (let* ((zform (%car revregargs))
2576               (yform (%cadr revregargs))
2577               (xform (%caddr revregargs)))
2578          (if (eq 3 nregs)
2579            (arm2-three-targeted-reg-forms seg xform ($ arm::arg_x) yform ($ arm::arg_y) zform ($ arm::arg_z))
2580            (if (eq 2 nregs)
2581              (arm2-two-targeted-reg-forms seg yform ($ arm::arg_y) zform ($ arm::arg_z))
2582              (arm2-one-targeted-reg-form seg zform ($ arm::arg_z))))))
2583      n)))
2584
2585(defun arm2-arglist (seg args)
2586  (arm2-formlist seg (car args) (cadr args)))
2587
2588
2589
2590
2591
2592(defun arm2-unboxed-integer-arg-to-reg (seg form immreg &optional ffi-arg-type)
2593  (let* ((mode (case ffi-arg-type
2594                 ((nil) :natural)
2595                 (:signed-byte :s8)
2596                 (:unsigned-byte :u8)
2597                 (:signed-halfword :s16)
2598                 (:unsigned-halfword :u16)
2599                 (:signed-fullword :s32)
2600                 (:unsigned-fullword :u32)
2601                 (:unsigned-doubleword :u64)
2602                 (:signed-doubleword :s64)))
2603         (modeval (gpr-mode-name-value mode)))
2604    (with-arm-local-vinsn-macros (seg)
2605      (let* ((value (arm2-integer-constant-p form mode)))
2606        (if value
2607            (progn
2608              (unless (typep immreg 'lreg)
2609                (setq immreg (make-unwired-lreg immreg :mode modeval)))
2610              (arm2-lri seg immreg value)
2611              immreg)
2612          (progn 
2613            (arm2-one-targeted-reg-form seg form (make-wired-lreg arm::imm0 :mode modeval))))))))
2614
2615
2616(defun arm2-macptr-arg-to-reg (seg form address-reg) 
2617  (arm2-one-targeted-reg-form seg
2618                              form 
2619                              address-reg))
2620
2621
2622(defun arm2-one-lreg-form (seg form lreg)
2623  (let ((is-float (= (hard-regspec-class lreg) hard-reg-class-fpr)))
2624    (if is-float
2625      (arm2-form-float seg lreg nil form)
2626      (arm2-form seg lreg nil form))
2627    lreg))
2628
2629(defun arm2-one-targeted-reg-form (seg form reg)
2630  (arm2-one-lreg-form seg form reg))
2631
2632(defun arm2-one-untargeted-lreg-form (seg form reg)
2633  (arm2-one-lreg-form seg form (if (typep reg 'lreg) reg (make-unwired-lreg reg))))
2634
2635(defun arm2-one-untargeted-reg-form (seg form suggested)
2636  (with-arm-local-vinsn-macros (seg)
2637    (let* ((gpr-p (= (hard-regspec-class suggested) hard-reg-class-gpr))
2638           (node-p (if gpr-p (= (get-regspec-mode suggested) hard-reg-class-gpr-mode-node))))
2639      (if node-p
2640        (let* ((ref (arm2-lexical-reference-ea form))
2641               (reg (backend-ea-physical-reg ref hard-reg-class-gpr)))
2642          (if reg
2643            ref
2644            (if (nx-null form)
2645              (progn
2646                (! load-nil suggested)
2647                suggested)
2648              (if (and (acode-p form) 
2649                       (eq (acode-operator form) (%nx1-operator immediate)) 
2650                       (setq reg (arm2-register-constant-p (cadr form))))
2651                reg
2652                (if (and (acode-p form)
2653                         (eq (acode-operator form) (%nx1-operator %current-tcr)))
2654                  arm::rcontext
2655                  (arm2-one-untargeted-lreg-form seg form suggested))))))
2656        (arm2-one-untargeted-lreg-form seg form suggested)))))
2657             
2658
2659(defun arm2-push-register (seg areg)
2660  (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr))
2661         (a-double (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-double)))
2662         (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node)))
2663         vinsn)
2664    (with-arm-local-vinsn-macros (seg)
2665      (if a-node
2666        (setq vinsn (arm2-vpush-register seg areg :node-temp))
2667        (progn
2668          (setq vinsn
2669                (if a-float
2670                  (if a-double
2671                    (! temp-push-double-float areg)
2672                    (! temp-push-single-float areg))
2673                  (! temp-push-unboxed-word areg)))
2674          (arm2-open-undo $undostkblk)))
2675      vinsn)))
2676
2677(defun arm2-pop-register (seg areg)
2678  (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr))
2679         (a-double (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-double)))
2680         (a-node (unless a-float (= (get-regspec-mode areg) hard-reg-class-gpr-mode-node)))
2681         vinsn)
2682    (with-arm-local-vinsn-macros (seg)
2683      (if a-node
2684        (setq vinsn (arm2-vpop-register seg areg))
2685        (progn
2686          (setq vinsn
2687                (if a-float
2688                  (if a-double
2689                    (! temp-pop-double-float areg)
2690                    (! temp-pop-single-float areg))
2691                  (! temp-pop-unboxed-word areg)))
2692          (arm2-close-undo)))
2693      vinsn)))
2694
2695(defun arm2-acc-reg-for (reg)
2696  (with-arm-local-vinsn-macros (seg)
2697    (if (and (eql (hard-regspec-class reg) hard-reg-class-gpr)
2698             (eql (get-regspec-mode reg) hard-reg-class-gpr-mode-node))
2699      ($ arm::arg_z)
2700      reg)))
2701
2702;;; The compiler often generates superfluous pushes & pops.  Try to
2703;;; eliminate them.
2704;;; It's easier to elide pushes and pops to the TSP.
2705(defun arm2-elide-pushes (seg push-vinsn pop-vinsn)
2706  (with-arm-local-vinsn-macros (seg)
2707    (let* ((pushed-reg (svref (vinsn-variable-parts push-vinsn) 0))
2708           (popped-reg (svref (vinsn-variable-parts pop-vinsn) 0))
2709           (same-reg (eq (hard-regspec-value pushed-reg)
2710                         (hard-regspec-value popped-reg)))
2711           (sp-p (vinsn-attribute-p push-vinsn :sp)))
2712      (when (and sp-p t)               ; vsp case is harder.
2713        (unless (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :tsp :discard)
2714          (let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p
2715                                     push-vinsn pop-vinsn pushed-reg))
2716                 (popped-reg-is-set (if same-reg
2717                                      pushed-reg-is-set
2718                                      (vinsn-sequence-sets-reg-p
2719                                       push-vinsn pop-vinsn popped-reg))))
2720            (unless (and pushed-reg-is-set popped-reg-is-set)
2721              (unless same-reg
2722                (let* ((copy (if (eq (hard-regspec-class pushed-reg)
2723                                     hard-reg-class-fpr)
2724                               (! copy-fpr popped-reg pushed-reg)
2725                               (! copy-gpr popped-reg pushed-reg))))
2726                  (remove-dll-node copy)
2727                  (if pushed-reg-is-set
2728                    (insert-dll-node-after copy push-vinsn)
2729                    (insert-dll-node-before copy push-vinsn))))
2730              (elide-vinsn push-vinsn)
2731              (elide-vinsn pop-vinsn))))))))
2732               
2733       
2734;;; we never leave the first form pushed (the 68K compiler had some subprims that
2735;;; would vpop the first argument out of line.)
2736(defun arm2-two-targeted-reg-forms (seg aform areg bform breg)
2737  (let* ((avar (arm2-lexical-reference-p aform))
2738         (atriv (and (arm2-trivial-p bform) (nx2-node-gpr-p breg)))
2739         (aconst (and (not atriv) (or (arm-side-effect-free-form-p aform)
2740                                      (if avar (arm2-var-not-set-by-form-p avar bform)))))
2741         (apushed (not (or atriv aconst))))
2742    (progn
2743      (unless aconst
2744        (if atriv
2745          (arm2-one-targeted-reg-form seg aform areg)
2746          (setq apushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg aform (arm2-acc-reg-for areg))))))
2747      (arm2-one-targeted-reg-form seg bform breg)
2748      (if aconst
2749        (arm2-one-targeted-reg-form seg aform areg)
2750        (if apushed
2751          (arm2-elide-pushes seg apushed (arm2-pop-register seg areg)))))
2752    (values areg breg)))
2753
2754
2755(defun arm2-two-untargeted-reg-forms (seg aform areg bform breg)
2756  (with-arm-local-vinsn-macros (seg)
2757    (let* ((avar (arm2-lexical-reference-p aform))
2758           (adest areg)
2759           (bdest breg)
2760           (atriv (and (arm2-trivial-p bform) (nx2-node-gpr-p breg)))
2761           (aconst (and (not atriv) (or (arm-side-effect-free-form-p aform)
2762                                        (if avar (arm2-var-not-set-by-form-p avar bform)))))
2763           (apushed (not (or atriv aconst))))
2764      (progn
2765        (unless aconst
2766          (if atriv
2767            (setq adest (arm2-one-untargeted-reg-form seg aform areg))
2768            (setq apushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg aform (arm2-acc-reg-for areg))))))
2769        (setq bdest (arm2-one-untargeted-reg-form seg bform breg))
2770        (if aconst
2771          (setq adest (arm2-one-untargeted-reg-form seg aform areg))
2772          (if apushed
2773            (arm2-elide-pushes seg apushed (arm2-pop-register seg areg)))))
2774      (values adest bdest))))
2775
2776
2777(defun arm2-four-targeted-reg-forms (seg aform areg bform breg cform creg dform dreg)
2778  (let* ((bnode (nx2-node-gpr-p breg))
2779         (cnode (nx2-node-gpr-p creg))
2780         (dnode (nx2-node-gpr-p dreg))
2781         (atriv (or (null aform) 
2782                    (and (arm2-trivial-p bform)
2783                         (arm2-trivial-p cform)
2784                         (arm2-trivial-p dform)
2785                         bnode
2786                         cnode
2787                         dnode)))
2788         (btriv (or (null bform)
2789                    (and (arm2-trivial-p cform)
2790                         (arm2-trivial-p dform)
2791                         cnode
2792                         dnode)))
2793         (ctriv (or (null cform)
2794                    (and (arm2-trivial-p dform) dnode)))
2795         
2796         (aconst (and (not atriv) 
2797                      (or (arm-side-effect-free-form-p aform)
2798                          (let ((avar (arm2-lexical-reference-p aform)))
2799                            (and avar 
2800                                 (arm2-var-not-set-by-form-p avar bform)
2801                                 (arm2-var-not-set-by-form-p avar cform)
2802                                 (arm2-var-not-set-by-form-p avar dform))))))
2803         (bconst (and (not btriv)
2804                      (or (arm-side-effect-free-form-p bform)
2805                          (let ((bvar (arm2-lexical-reference-p bform)))
2806                            (and bvar
2807                                 (arm2-var-not-set-by-form-p bvar cform)
2808                                 (arm2-var-not-set-by-form-p bvar dform))))))
2809         (cconst (and (not ctriv)
2810                      (or (arm-side-effect-free-form-p cform)
2811                          (let ((cvar (arm2-lexical-reference-p cform)))
2812                            (and cvar
2813                                 (arm2-var-not-set-by-form-p cvar dform))))))
2814         (apushed nil)
2815         (bpushed nil)
2816         (cpushed nil))
2817    (if (and aform (not aconst))
2818      (if atriv
2819        (arm2-one-targeted-reg-form seg aform areg)
2820        (setq apushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg aform (arm2-acc-reg-for areg))))))
2821    (if (and bform (not bconst))
2822      (if btriv
2823        (arm2-one-targeted-reg-form seg bform breg)
2824        (setq bpushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg bform (arm2-acc-reg-for breg))))))
2825    (if (and cform (not cconst))
2826      (if ctriv
2827        (arm2-one-targeted-reg-form seg cform creg)
2828        (setq cpushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg cform (arm2-acc-reg-for creg))))))
2829    (arm2-one-targeted-reg-form seg dform dreg)
2830    (unless ctriv
2831      (if cconst
2832        (arm2-one-targeted-reg-form seg cform creg)
2833        (arm2-elide-pushes seg cpushed (arm2-pop-register seg creg))))
2834    (unless btriv 
2835      (if bconst
2836        (arm2-one-targeted-reg-form seg bform breg)
2837        (arm2-elide-pushes seg bpushed (arm2-pop-register seg breg))))
2838    (unless atriv
2839      (if aconst
2840        (arm2-one-targeted-reg-form seg aform areg)
2841        (arm2-elide-pushes seg apushed (arm2-pop-register seg areg))))
2842    (values areg breg creg dreg)))
2843
2844(defun arm2-three-targeted-reg-forms (seg aform areg bform breg cform creg)
2845  (let* ((bnode (nx2-node-gpr-p breg))
2846         (cnode (nx2-node-gpr-p creg))
2847         (atriv (or (null aform) 
2848                    (and (arm2-trivial-p bform)
2849                         (arm2-trivial-p cform)
2850                         bnode
2851                         cnode)))
2852         (btriv (or (null bform)
2853                    (and (arm2-trivial-p cform)
2854                         cnode)))
2855         (aconst (and (not atriv) 
2856                      (or (arm-side-effect-free-form-p aform)
2857                          (let ((avar (arm2-lexical-reference-p aform)))
2858                            (and avar 
2859                                 (arm2-var-not-set-by-form-p avar bform)
2860                                 (arm2-var-not-set-by-form-p avar cform))))))
2861         (bconst (and (not btriv)
2862                      (or
2863                       (arm-side-effect-free-form-p bform)
2864                       (let ((bvar (arm2-lexical-reference-p bform)))
2865                         (and bvar (arm2-var-not-set-by-form-p bvar cform))))))
2866         (apushed nil)
2867         (bpushed nil))
2868    (if (and aform (not aconst))
2869      (if atriv
2870        (arm2-one-targeted-reg-form seg aform areg)
2871        (setq apushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg aform (arm2-acc-reg-for areg))))))
2872    (if (and bform (not bconst))
2873      (if btriv
2874        (arm2-one-targeted-reg-form seg bform breg)
2875        (setq bpushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg bform (arm2-acc-reg-for breg))))))
2876    (arm2-one-targeted-reg-form seg cform creg)
2877    (unless btriv 
2878      (if bconst
2879        (arm2-one-targeted-reg-form seg bform breg)
2880        (arm2-elide-pushes seg bpushed (arm2-pop-register seg breg))))
2881    (unless atriv
2882      (if aconst
2883        (arm2-one-targeted-reg-form seg aform areg)
2884        (arm2-elide-pushes seg apushed (arm2-pop-register seg areg))))
2885    (values areg breg creg)))
2886
2887(defun arm2-three-untargeted-reg-forms (seg aform areg bform breg cform creg)
2888  (with-arm-local-vinsn-macros (seg)
2889    (let* ((bnode (nx2-node-gpr-p breg))
2890           (cnode (nx2-node-gpr-p creg))
2891           (atriv (or (null aform) 
2892                      (and (arm2-trivial-p bform)
2893                           (arm2-trivial-p cform)
2894                           bnode
2895                           cnode)))
2896           (btriv (or (null bform)
2897                      (and (arm2-trivial-p cform)
2898                           cnode)))
2899           (aconst (and (not atriv) 
2900                        (or (arm-side-effect-free-form-p aform)
2901                            (let ((avar (arm2-lexical-reference-p aform)))
2902                              (and avar 
2903                                   (arm2-var-not-set-by-form-p avar bform)
2904                                   (arm2-var-not-set-by-form-p avar cform))))))
2905           (bconst (and (not btriv)
2906                        (or
2907                         (arm-side-effect-free-form-p bform)
2908                         (let ((bvar (arm2-lexical-reference-p bform)))
2909                           (and bvar (arm2-var-not-set-by-form-p bvar cform))))))
2910           (adest areg)
2911           (bdest breg)
2912           (cdest creg)
2913           (apushed nil)
2914           (bpushed nil))
2915      (if (and aform (not aconst))
2916        (if atriv
2917          (setq adest (arm2-one-untargeted-reg-form seg aform ($ areg)))
2918          (setq apushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg aform (arm2-acc-reg-for areg))))))
2919      (if (and bform (not bconst))
2920        (if btriv
2921          (setq bdest (arm2-one-untargeted-reg-form seg bform ($ breg)))
2922          (setq bpushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg bform (arm2-acc-reg-for breg))))))
2923      (setq cdest (arm2-one-untargeted-reg-form seg cform creg))
2924      (unless btriv 
2925        (if bconst
2926          (setq bdest (arm2-one-untargeted-reg-form seg bform breg))
2927          (arm2-elide-pushes seg bpushed (arm2-pop-register seg breg))))
2928      (unless atriv
2929        (if aconst
2930          (setq adest (arm2-one-untargeted-reg-form seg aform areg))
2931          (arm2-elide-pushes seg apushed (arm2-pop-register seg areg))))
2932      (values adest bdest cdest))))
2933
2934(defun arm2-four-untargeted-reg-forms (seg aform areg bform breg cform creg dform dreg)
2935  (let* ((bnode (nx2-node-gpr-p breg))
2936         (cnode (nx2-node-gpr-p creg))
2937         (dnode (nx2-node-gpr-p dreg))
2938         (atriv (or (null aform) 
2939                    (and (arm2-trivial-p bform)
2940                         (arm2-trivial-p cform)
2941                         (arm2-trivial-p dform)
2942                         bnode
2943                         cnode
2944                         dnode)))
2945         (btriv (or (null bform)
2946                    (and (arm2-trivial-p cform)
2947                         (arm2-trivial-p dform)
2948                         cnode
2949                         dnode)))
2950         (ctriv (or (null cform)
2951                    (and (arm2-trivial-p dform) dnode)))
2952         (aconst (and (not atriv) 
2953                      (or (arm-side-effect-free-form-p aform)
2954                          (let ((avar (arm2-lexical-reference-p aform)))
2955                            (and avar 
2956                                 (arm2-var-not-set-by-form-p avar bform)
2957                                 (arm2-var-not-set-by-form-p avar cform)
2958                                 (arm2-var-not-set-by-form-p avar dform))))))
2959         (bconst (and (not btriv)
2960                      (or
2961                       (arm-side-effect-free-form-p bform)
2962                       (let ((bvar (arm2-lexical-reference-p bform)))
2963                         (and bvar
2964                              (arm2-var-not-set-by-form-p bvar cform)
2965                              (arm2-var-not-set-by-form-p bvar dform))))))
2966         (cconst (and (not ctriv)
2967                      (or
2968                       (arm-side-effect-free-form-p cform)
2969                       (let ((cvar (arm2-lexical-reference-p cform)))
2970                         (and cvar
2971                              (arm2-var-not-set-by-form-p cvar dform))))))
2972         (adest areg)
2973         (bdest breg)
2974         (cdest creg)
2975         (ddest dreg)
2976         (apushed nil)
2977         (bpushed nil)
2978         (cpushed nil))
2979    (if (and aform (not aconst))
2980      (if atriv
2981        (setq adest (arm2-one-targeted-reg-form seg aform areg))
2982        (setq apushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg aform (arm2-acc-reg-for areg))))))
2983    (if (and bform (not bconst))
2984      (if btriv
2985        (setq bdest (arm2-one-untargeted-reg-form seg bform breg))
2986        (setq bpushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg bform (arm2-acc-reg-for breg))))))
2987    (if (and cform (not cconst))
2988      (if ctriv
2989        (setq cdest (arm2-one-untargeted-reg-form seg cform creg))
2990        (setq cpushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg cform (arm2-acc-reg-for creg))))))
2991    (setq ddest (arm2-one-untargeted-reg-form seg dform dreg))
2992    (unless ctriv 
2993      (if cconst
2994        (setq cdest (arm2-one-untargeted-reg-form seg cform creg))
2995        (arm2-elide-pushes seg cpushed (arm2-pop-register seg creg))))
2996    (unless btriv 
2997      (if bconst
2998        (setq bdest (arm2-one-untargeted-reg-form seg bform breg))
2999        (arm2-elide-pushes seg bpushed (arm2-pop-register seg breg))))
3000    (unless atriv
3001      (if aconst
3002        (setq adest (arm2-one-untargeted-reg-form seg aform areg))
3003        (arm2-elide-pushes seg apushed (arm2-pop-register seg areg))))
3004    (values adest bdest cdest ddest)))
3005
3006(defun arm2-lri (seg reg value)
3007  (with-arm-local-vinsn-macros (seg)
3008    (if (>= value 0)
3009      (! lri reg value)
3010      (! lri reg (logand value #xffffffff)))))
3011
3012
3013(defun arm2-multiple-value-body (seg form)
3014  (let* ((lab (backend-get-next-label))
3015         (*arm2-vstack* *arm2-vstack*)
3016         (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*)
3017         (old-stack (arm2-encode-stack)))
3018    (with-arm-local-vinsn-macros (seg)
3019      (arm2-open-undo $undomvexpect)
3020      (arm2-undo-body seg nil (logior $backend-mvpass-mask lab) form old-stack)
3021      (@ lab))))
3022
3023(defun arm2-afunc-lfun-ref (afunc)
3024  (or
3025   (afunc-lfun afunc)
3026   (progn (pushnew afunc (afunc-fwd-refs *arm2-cur-afunc*) :test #'eq)
3027          afunc)))
3028
3029(defun arm2-augment-arglist (afunc arglist &optional (maxregs $numarmargregs))
3030  (let ((inherited-args (afunc-inherited-vars afunc)))
3031    (when inherited-args
3032      (let* ((current-afunc *arm2-cur-afunc*)
3033             (stkargs (car arglist))
3034             (regargs (cadr arglist))
3035             (inhforms nil)
3036             (numregs (length regargs))
3037             (own-inhvars (afunc-inherited-vars current-afunc)))
3038        (dolist (var inherited-args)
3039          (let* ((root-var (nx-root-var var))
3040                 (other-guy 
3041                  (dolist (v own-inhvars #|(compiler-bug "other guy not found")|# root-var)
3042                    (when (eq root-var (nx-root-var v)) (return v)))))
3043            (push (make-acode (%nx1-operator inherited-arg) other-guy) inhforms)))
3044        (dolist (form inhforms)
3045          (if (%i< numregs maxregs)
3046            (progn
3047              (setq regargs (nconc regargs (list form)))
3048              (setq numregs (%i+ numregs 1)))
3049            (push form stkargs)))
3050        (%rplaca (%cdr arglist) regargs) ; might have started out NIL.
3051        (%rplaca arglist stkargs)))) 
3052  arglist)
3053
3054(defun arm2-constant-for-compare-p (form)
3055  (setq form (acode-unwrapped-form form))
3056  (when (acode-p form)
3057    (let* ((op (acode-operator form)))
3058      (if (eql op (%nx1-operator fixnum))
3059        (let* ((val (ash (cadr form) arm::fixnumshift)))
3060          (if (arm::encode-arm-immediate val)
3061            (logand val #xffffffff)
3062            (if (arm::encode-arm-immediate (lognot val))
3063              (logand (lognot val) #xffffffff))))
3064        (if (eql op (%nx1-operator %unbound-marker))
3065          arm::unbound-marker
3066          (if (eql op (%nx1-operator %slot-unbound-marker))
3067            arm::slot-unbound-marker))))))
3068
3069
3070;;; There are other cases involving constants that are worth exploiting.
3071(defun arm2-compare (seg vreg xfer i j cr-bit true-p)
3072  (with-arm-local-vinsn-macros (seg vreg xfer)
3073    (let* ((jconst (arm2-constant-for-compare-p j))
3074           (iconst (arm2-constant-for-compare-p i))
3075           (boolean (backend-crf-p vreg)))
3076      (if (and boolean (or iconst jconst))
3077        (let* ((reg (arm2-one-untargeted-reg-form seg (if jconst i j) arm::arg_z)))
3078          (! compare-immediate vreg reg (or jconst iconst))
3079          (unless (or jconst (eq cr-bit arm::arm-cond-eq))
3080            (setq cr-bit (logxor cr-bit 1)))
3081          (^ cr-bit true-p))
3082        (if (and (eq cr-bit arm::arm-cond-eq) 
3083                 (or jconst iconst))
3084          (arm2-test-reg-%izerop 
3085           seg 
3086           vreg 
3087           xfer 
3088           (arm2-one-untargeted-reg-form 
3089            seg 
3090            (if jconst i j) 
3091            arm::arg_z) 
3092           cr-bit 
3093           true-p 
3094           (or jconst iconst))
3095          (multiple-value-bind (ireg jreg) (arm2-two-untargeted-reg-forms seg i arm::arg_y j arm::arg_z)
3096            (arm2-compare-registers seg vreg xfer ireg jreg cr-bit true-p)))))))
3097
3098
3099
3100(defun arm2-compare-registers (seg vreg xfer ireg jreg cr-bit true-p)
3101  (with-arm-local-vinsn-macros (seg vreg xfer)
3102    (if vreg
3103      (regspec-crf-gpr-case 
3104       (vreg dest)
3105       (progn
3106         (! compare dest ireg jreg)
3107         (^ cr-bit true-p))
3108       (with-crf-target () crf
3109         (! compare crf ireg jreg)
3110         (ensuring-node-target (target vreg)
3111           (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))))
3112         (^)))
3113      (^))))
3114
3115(defun arm2-compare-register-to-nil (seg vreg xfer ireg cr-bit true-p)
3116  (with-arm-local-vinsn-macros (seg vreg xfer)
3117    (if vreg
3118      (regspec-crf-gpr-case 
3119       (vreg dest)
3120       (progn
3121         (! compare-to-nil dest ireg)
3122         (^ cr-bit true-p))
3123       (with-crf-target () crf
3124         (! compare-to-nil crf ireg)
3125         (ensuring-node-target (target dest)
3126           (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))))
3127         (^)))
3128      (^))))
3129
3130;;; Have to extract a bit out of the CR when a boolean result needed.
3131(defun arm2-compare-double-float-registers (seg vreg xfer ireg jreg cr-bit true-p)
3132  (with-arm-local-vinsn-macros (seg vreg xfer)
3133    (if vreg
3134      (regspec-crf-gpr-case 
3135       (vreg dest)
3136       (progn
3137         (! double-float-compare dest ireg jreg)
3138         (^ cr-bit true-p))
3139       (progn
3140         (with-crf-target () flags
3141           (! double-float-compare flags ireg jreg)
3142
3143           (! cond->boolean dest (if true-p cr-bit (logxor cr-bit 1))))
3144         (^)))
3145      (^))))
3146
3147
3148(defun arm2-immediate-form-p (form)
3149  (if (and (consp form)
3150           (or (eq (%car form) (%nx1-operator immediate))
3151               (eq (%car form) (%nx1-operator simple-function))))
3152    t))
3153
3154(defun arm2-test-%izerop (seg vreg xfer form cr-bit true-p)
3155  (arm2-test-reg-%izerop seg vreg xfer (arm2-one-untargeted-reg-form seg form arm::arg_z) cr-bit true-p 0))
3156
3157(defun arm2-test-reg-%izerop (seg vreg xfer reg cr-bit true-p  zero)
3158  (declare (fixnum reg zero))
3159  (with-arm-local-vinsn-macros (seg vreg xfer)
3160    (regspec-crf-gpr-case 
3161     (vreg dest)
3162     (progn
3163       (if (or (arm::encode-arm-immediate zero)
3164               (arm::encode-arm-immediate (lognot zero)))
3165         (! compare-immediate dest reg zero)
3166         (with-node-target (reg) other
3167           (arm2-lri seg other zero)
3168           (! compare dest reg other)))
3169       (^ cr-bit true-p))
3170     (with-crf-target () crf
3171       (if (or (arm::encode-arm-immediate zero)
3172               (arm::encode-arm-immediate (lognot zero)))
3173         (! compare-immediate crf reg (logand #xffffffff zero))
3174         (with-node-target (reg) other
3175           (arm2-lri seg other zero)
3176           (! compare crf reg other)))
3177       (ensuring-node-target (target dest)
3178         (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))))
3179       (^)))))
3180
3181(defun arm2-lexical-reference-ea (form &optional (no-closed-p t))
3182  (when (acode-p (setq form (acode-unwrapped-form-value form)))
3183    (if (eq (acode-operator form) (%nx1-operator lexical-reference))
3184      (let* ((addr (var-ea (%cadr form))))
3185        (if (typep addr 'lreg)
3186          addr
3187          (unless (and no-closed-p (addrspec-vcell-p addr ))
3188            addr))))))
3189
3190
3191(defun arm2-vpush-register (seg src &optional why info attr)
3192  (with-arm-local-vinsn-macros (seg)
3193    (prog1
3194      (! vpush-register src)
3195      (arm2-regmap-note-store src *arm2-vstack*)
3196      (arm2-new-vstack-lcell (or why :node) *arm2-target-lcell-size* (or attr 0) info)
3197      (arm2-adjust-vstack *arm2-target-node-size*))))
3198
3199(defun arm2-vpush-register-arg (seg src)
3200  (arm2-vpush-register seg src :outgoing-argument))
3201
3202
3203(defun arm2-vpop-register (seg dest)
3204  (with-arm-local-vinsn-macros (seg)
3205    (prog1
3206      (! vpop-register dest)
3207      (setq *arm2-top-vstack-lcell* (lcell-parent *arm2-top-vstack-lcell*))
3208      (arm2-adjust-vstack (- *arm2-target-node-size*)))))
3209
3210(defun arm2-copy-register (seg dest src)
3211  (with-arm-local-vinsn-macros (seg)
3212    (when dest
3213      (let* ((dest-gpr (backend-ea-physical-reg dest hard-reg-class-gpr))
3214             (src-gpr (if src (backend-ea-physical-reg src hard-reg-class-gpr)))
3215             (dest-fpr (backend-ea-physical-reg dest hard-reg-class-fpr))
3216             (src-fpr (if src (backend-ea-physical-reg src hard-reg-class-fpr)))
3217             (src-mode (if src (get-regspec-mode src)))
3218             (dest-mode (get-regspec-mode dest))
3219             (dest-crf (backend-ea-physical-reg dest hard-reg-class-crf)))
3220        (if (null src)
3221          (if dest-gpr
3222            (! load-nil dest-gpr)
3223            (if dest-crf
3224              (! set-eq-bit dest-crf)))
3225          (if (and dest-crf src-gpr)
3226            ;; "Copying" a GPR to a CR field means comparing it to rnil
3227            (! compare-to-nil dest src)
3228            (if (and dest-gpr src-gpr)
3229              (case dest-mode
3230                (#.hard-reg-class-gpr-mode-node ; boxed result.
3231                 (case src-mode
3232                   (#.hard-reg-class-gpr-mode-node
3233                    (unless (eql  dest-gpr src-gpr)
3234                      (! copy-gpr dest src)))
3235                   (#.hard-reg-class-gpr-mode-u32
3236                    (arm2-box-u32 seg dest src))
3237                   (#.hard-reg-class-gpr-mode-s32
3238                    (arm2-box-s32 seg dest src))
3239                   (#.hard-reg-class-gpr-mode-u16
3240                    (! u16->fixnum dest src))
3241                   (#.hard-reg-class-gpr-mode-s16
3242                    (! s16->fixnum dest src))
3243                   (#.hard-reg-class-gpr-mode-u8
3244                    (! u8->fixnum dest src))
3245                   (#.hard-reg-class-gpr-mode-s8
3246                    (! s8->fixnum dest src))
3247                   (#.hard-reg-class-gpr-mode-address
3248                    (! macptr->heap dest src))))
3249                ((#.hard-reg-class-gpr-mode-u32
3250                  #.hard-reg-class-gpr-mode-address)
3251                 (case src-mode
3252                   (#.hard-reg-class-gpr-mode-node
3253                    (let* ((src-type (get-node-regspec-type-modes src)))
3254                      (declare (fixnum src-type))
3255                      (case dest-mode
3256                        (#.hard-reg-class-gpr-mode-u32
3257                         (! unbox-u32 dest src))
3258                        (#.hard-reg-class-gpr-mode-address
3259                         (unless (or (logbitp #.hard-reg-class-gpr-mode-address src-type)
3260                                     *arm2-reckless*)
3261                           (! trap-unless-macptr src))
3262                         (! deref-macptr dest src)))))
3263                   ((#.hard-reg-class-gpr-mode-u32
3264                     #.hard-reg-class-gpr-mode-s32
3265                     #.hard-reg-class-gpr-mode-address)
3266                    (unless (eql  dest-gpr src-gpr)
3267                      (! copy-gpr dest src)))
3268                   ((#.hard-reg-class-gpr-mode-u16
3269                     #.hard-reg-class-gpr-mode-s16)
3270                    (! u16->u32 dest src))
3271                   ((#.hard-reg-class-gpr-mode-u8
3272                     #.hard-reg-class-gpr-mode-s8)
3273                    (! u8->u32 dest src))))
3274                (#.hard-reg-class-gpr-mode-s32
3275                 (case src-mode
3276                   (#.hard-reg-class-gpr-mode-node
3277                    (! unbox-s32 dest src))
3278                   ((#.hard-reg-class-gpr-mode-u32
3279                     #.hard-reg-class-gpr-mode-s32
3280                     #.hard-reg-class-gpr-mode-address)
3281                    (unless (eql  dest-gpr src-gpr)
3282                      (! copy-gpr dest src)))
3283                   (#.hard-reg-class-gpr-mode-u16
3284                    (! u16->u32 dest src))                 
3285                   (#.hard-reg-class-gpr-mode-s16
3286                    (! s16->s32 dest src))
3287                   (#.hard-reg-class-gpr-mode-u8
3288                    (! u8->u32 dest src))
3289                   (#.hard-reg-class-gpr-mode-s8
3290                    (! s8->s32 dest src))))
3291                (#.hard-reg-class-gpr-mode-u16
3292                 (case src-mode
3293                   (#.hard-reg-class-gpr-mode-node
3294                    (! unbox-u16 dest src))
3295                   ((#.hard-reg-class-gpr-mode-u8
3296                     #.hard-reg-class-gpr-mode-s8)
3297                    (! u8->u32 dest src))
3298                   (t
3299                    (unless (eql dest-gpr src-gpr)
3300                      (! copy-gpr dest src)))))
3301                (#.hard-reg-class-gpr-mode-s16
3302                 (case src-mode
3303                   (#.hard-reg-class-gpr-mode-node
3304                    (! unbox-s16 dest src))
3305                   (#.hard-reg-class-gpr-mode-s8
3306                    (! s8->s32 dest src))
3307                   (#.hard-reg-class-gpr-mode-u8
3308                    (! u8->u32 dest src))
3309                   (t
3310                    (unless (eql dest-gpr src-gpr)
3311                      (! copy-gpr dest src)))))
3312                (#.hard-reg-class-gpr-mode-u8
3313                 (case src-mode
3314                   (#.hard-reg-class-gpr-mode-node
3315                    (if *arm2-reckless*
3316                      (! %unbox-u8 dest src)
3317                      (! unbox-u8 dest src)))
3318                   (t
3319                    (unless (eql dest-gpr src-gpr)
3320                      (! copy-gpr dest src)))))
3321                (#.hard-reg-class-gpr-mode-s8
3322                 (case src-mode
3323                   (#.hard-reg-class-gpr-mode-node
3324                    (! unbox-s8 dest src))
3325                   (t
3326                    (unless (eql dest-gpr src-gpr)
3327                      (! copy-gpr dest src))))))
3328              (if src-gpr
3329                (if dest-fpr
3330                  (progn
3331                    (case src-mode
3332                      (#.hard-reg-class-gpr-mode-node
3333                       (case dest-mode
3334                         (#.hard-reg-class-fpr-mode-double
3335                          (unless (or (logbitp hard-reg-class-fpr-type-double 
3336                                               (get-node-regspec-type-modes src))
3337                                      *arm2-reckless*)
3338                            (! trap-unless-double-float src))
3339                          (! get-double dest src))
3340                         (#.hard-reg-class-fpr-mode-single
3341                          (unless *arm2-reckless*
3342                            (! trap-unless-single-float src))
3343                          (! get-single dest src)))))))
3344                (if dest-gpr
3345                  (case dest-mode
3346                    (#.hard-reg-class-gpr-mode-node
3347                     (case src-mode
3348                       (#.hard-reg-class-fpr-mode-double
3349                        (! double->heap dest src))
3350                       (#.hard-reg-class-fpr-mode-single
3351                        (! single->node dest src)))))
3352                  (if (and src-fpr dest-fpr)
3353                    (unless (eql dest-fpr src-fpr)
3354                      (! copy-fpr dest src))))))))))))
3355 
3356(defun arm2-unreachable-store (&optional vreg)
3357  ;; I don't think that anything needs to be done here,
3358  ;; but leave this guy around until we're sure.
3359  ;; (ARM2-VPUSH-REGISTER will always vpush something, even
3360  ;; if code to -load- that "something" never gets generated.
3361  ;; If I'm right about this, that means that the compile-time
3362  ;; stack-discipline problem that this is supposed to deal
3363  ;; with can't happen.)
3364  (declare (ignore vreg))
3365  nil)
3366
3367;;; bind vars to initforms, as per let*, &aux.
3368(defun arm2-seq-bind (seg vars initforms)
3369  (dolist (var vars)
3370    (arm2-seq-bind-var seg var (pop initforms))))
3371
3372(defun arm2-dynamic-extent-form (seg curstack val &aux (form val))
3373  (when (acode-p form)
3374    (with-note (form seg curstack) ; note this rebinds form/seg/curstack so can't setq
3375      (with-arm-local-vinsn-macros (seg)
3376        (let* ((op (acode-operator form)))
3377          (cond ((eq op (%nx1-operator list))
3378                 (let* ((*arm2-vstack* *arm2-vstack*)
3379                        (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*))
3380                   (arm2-set-nargs seg (arm2-formlist seg (%cadr form) nil))
3381                   (arm2-open-undo $undostkblk curstack)
3382                   (! stack-cons-list))
3383                 (setq val arm::arg_z))
3384                ((eq op (%nx1-operator list*))
3385                 (let* ((arglist (%cadr form)))                   
3386                   (let* ((*arm2-vstack* *arm2-vstack*)
3387                          (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*))
3388                     (arm2-arglist seg arglist))
3389                   (when (car arglist)
3390                     (arm2-set-nargs seg (length (%car arglist)))
3391                     (! stack-cons-list*)
3392                     (arm2-open-undo $undostkblk curstack))
3393                   (setq val arm::arg_z)))
3394                ((eq op (%nx1-operator multiple-value-list))
3395                 (arm2-multiple-value-body seg (%cadr form))
3396                 (arm2-open-undo $undostkblk curstack)
3397                 (! stack-cons-list)
3398                 (setq val arm::arg_z))
3399                ((eq op (%nx1-operator cons))
3400                 (let* ((y ($ arm::arg_y))
3401                        (z ($ arm::arg_z))
3402                        (result ($ arm::arg_z)))
3403                   (arm2-two-targeted-reg-forms seg (%cadr form) y (%caddr form) z)
3404                   (arm2-open-undo $undostkblk )
3405                   (! make-stack-cons result y z) 
3406                   (setq val result)))
3407                ((eq op (%nx1-operator %consmacptr%))
3408                 (with-imm-target () (address :address)
3409                   (arm2-one-targeted-reg-form seg form address)
3410                   (with-node-temps () (node)
3411                     (! macptr->stack node address)
3412                     (arm2-open-undo $undostkblk)
3413                     (setq val node))))
3414                ((eq op (%nx1-operator %new-ptr))
3415                 (let* ((clear-form (caddr form))
3416                        (cval (nx2-constant-form-value clear-form)))
3417                   (if cval
3418                       (progn 
3419                         (arm2-one-targeted-reg-form seg (%cadr form) ($ arm::arg_z))
3420                         (if (nx-null cval)
3421                             (! make-stack-block)
3422                             (! make-stack-block0)))
3423                       (with-crf-target () crf
3424                         (let ((stack-block-0-label (backend-get-next-label))
3425                               (done-label (backend-get-next-label))
3426                               (rval ($ arm::arg_z))
3427                               (rclear ($ arm::arg_y)))
3428                           (arm2-two-targeted-reg-forms seg (%cadr form) rval clear-form rclear)
3429                           (! compare-to-nil crf rclear)
3430                           (! cbranch-false (aref *backend-labels* stack-block-0-label) crf arm::arm-cond-eq)
3431                           (! make-stack-block)
3432                           (-> done-label)
3433                           (@ stack-block-0-label)
3434                           (! make-stack-block0)
3435                           (@ done-label)))))
3436                 (arm2-open-undo $undostkblk)
3437                 (setq val ($ arm::arg_z)))
3438                ((eq op (%nx1-operator make-list))
3439                 (arm2-two-targeted-reg-forms seg (%cadr form) ($ arm::arg_y) (%caddr form) ($ arm::arg_z))
3440                 (arm2-open-undo $undostkblk curstack)
3441                 (! make-stack-list)
3442                 (setq val arm::arg_z))       
3443                ((eq op (%nx1-operator vector))
3444                 (let* ((*arm2-vstack* *arm2-vstack*)
3445                        (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*))
3446                   (arm2-set-nargs seg (arm2-formlist seg (%cadr form) nil))
3447                   (! make-stack-vector))
3448                 (arm2-open-undo $undostkblk)
3449                 (setq val arm::arg_z))
3450                ((eq op (%nx1-operator %gvector))
3451                 (let* ((*arm2-vstack* *arm2-vstack*)
3452                        (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*)
3453                        (arglist (%cadr form)))
3454                   (arm2-set-nargs seg (arm2-formlist seg (append (car arglist) (reverse (cadr arglist))) nil))
3455                   (! make-stack-gvector))
3456                 (arm2-open-undo $undostkblk)
3457                 (setq val arm::arg_z)) 
3458                ((eq op (%nx1-operator closed-function)) 
3459                 (setq val (arm2-make-closure seg (cadr form) t))) ; can't error
3460                ((eq op (%nx1-operator %make-uvector))
3461                 (destructuring-bind (element-count subtag &optional (init 0 init-p)) (%cdr form)
3462                   (if init-p
3463                       (progn
3464                         (arm2-three-targeted-reg-forms seg element-count ($ arm::arg_x) subtag ($ arm::arg_y) init ($ arm::arg_z))
3465                         (! stack-misc-alloc-init))
3466                       (progn
3467                         (arm2-two-targeted-reg-forms seg element-count ($ arm::arg_y)  subtag ($ arm::arg_z))
3468                         (! stack-misc-alloc)))
3469                   (arm2-open-undo $undostkblk)
3470                   (setq val ($ arm::arg_z)))))))))
3471  val)
3472
3473(defun arm2-addrspec-to-reg (seg addrspec reg)
3474  (if (memory-spec-p addrspec)
3475    (arm2-stack-to-register seg addrspec reg)
3476    (arm2-copy-register seg reg addrspec)))
3477 
3478(defun arm2-seq-bind-var (seg var val)
3479  (with-arm-local-vinsn-macros (seg)
3480    (let* ((sym (var-name var))
3481           (bits (nx-var-bits var))
3482           (closed-p (and (%ilogbitp $vbitclosed bits)
3483                          (%ilogbitp $vbitsetq bits)))
3484           (curstack (arm2-encode-stack))
3485           (make-vcell (and closed-p (eq bits (var-bits var))))
3486           (closed-downward (and closed-p (%ilogbitp $vbitcloseddownward bits))))
3487      (unless (fixnump val)
3488        (setq val (nx-untyped-form val))
3489        (when (and (%ilogbitp $vbitdynamicextent bits) (acode-p val))
3490          (setq val (arm2-dynamic-extent-form seg curstack val))))
3491      (if (%ilogbitp $vbitspecial bits)
3492        (progn
3493          (arm2-dbind seg val sym)
3494          (arm2-set-var-ea seg var (arm2-vloc-ea (- *arm2-vstack* *arm2-target-node-size*))))
3495        (let ((puntval nil))
3496          (flet ((arm2-puntable-binding-p (var initform)
3497                   ; The value returned is acode.
3498                   (let* ((bits (nx-var-bits var)))
3499                     (if (%ilogbitp $vbitpuntable bits)
3500                       initform))))
3501            (declare (inline arm2-puntable-binding-p))
3502            (if (and (not (arm2-load-ea-p val))
3503                     (setq puntval (arm2-puntable-binding-p var val)))
3504              (progn
3505                (nx-set-var-bits var (%ilogior (%ilsl $vbitpunted 1) bits))
3506                (nx2-replace-var-refs var puntval)
3507                (arm2-set-var-ea seg var puntval))
3508              (progn
3509                (let* ((vloc *arm2-vstack*)
3510                       (reg (let* ((r (nx2-assign-register-var var)))
3511                              (if r ($ r)))))
3512                  (if (arm2-load-ea-p val)
3513                    (if reg
3514                      (arm2-addrspec-to-reg seg val reg)
3515                      (if (memory-spec-p val)
3516                        (with-node-temps () (temp)
3517                          (arm2-addrspec-to-reg seg val temp)
3518                          (arm2-vpush-register seg temp :node var bits))
3519                        (arm2-vpush-register seg val :node var bits)))
3520                    (if reg
3521                      (arm2-one-targeted-reg-form seg val reg)
3522                      (arm2-vpush-register seg (arm2-one-untargeted-reg-form seg val arm::arg_z) :node var bits)))
3523                  (arm2-set-var-ea seg var (or reg (arm2-vloc-ea vloc closed-p)))
3524                  (if reg
3525                    (arm2-note-var-cell var reg)
3526                    (arm2-note-top-cell var))
3527                  (when make-vcell
3528                    (with-node-temps () (vcell closed)
3529                        (arm2-stack-to-register seg vloc closed)
3530                        (if closed-downward
3531                          (progn
3532                            (! make-stack-vcell vcell closed)
3533                            (arm2-open-undo $undostkblk))
3534                          (! make-vcell vcell closed))
3535                        (arm2-register-to-stack seg vcell vloc))))))))))))
3536
3537
3538
3539;;; Never make a vcell if this is an inherited var.
3540;;; If the var's inherited, its bits won't be a fixnum (and will
3541;;; therefore be different from what NX-VAR-BITS returns.)
3542(defun arm2-bind-var (seg var vloc &optional lcell &aux 
3543                          (bits (nx-var-bits var)) 
3544                          (closed-p (and (%ilogbitp $vbitclosed bits) (%ilogbitp $vbitsetq bits)))
3545                          (closed-downward (if closed-p (%ilogbitp $vbitcloseddownward bits)))
3546                          (make-vcell (and closed-p (eq bits (var-bits var))))
3547                          (addr (arm2-vloc-ea vloc)))
3548  (with-arm-local-vinsn-macros (seg)
3549    (if (%ilogbitp $vbitspecial bits)
3550      (progn
3551        (arm2-dbind seg addr (var-name var))
3552        (arm2-set-var-ea seg var (arm2-vloc-ea (- *arm2-vstack* *arm2-target-node-size*)))
3553        t)
3554      (progn
3555        (when (%ilogbitp $vbitpunted bits)
3556          (compiler-bug "bind-var: var ~s was punted" var))
3557        (when make-vcell
3558          (with-node-temps () (vcell closed)
3559            (arm2-stack-to-register seg vloc closed)
3560            (if closed-downward
3561              (progn
3562                (! make-stack-vcell vcell closed)
3563                (arm2-open-undo $undostkblk))
3564              (! make-vcell vcell closed))
3565            (arm2-register-to-stack seg vcell vloc)))
3566        (when lcell
3567          (setf (lcell-kind lcell) :node
3568                (lcell-attributes lcell) bits
3569                (lcell-info lcell) var)
3570          (arm2-note-var-cell var lcell))         
3571        (arm2-set-var-ea seg var (arm2-vloc-ea vloc closed-p))       
3572        closed-downward))))
3573
3574(defun arm2-set-var-ea (seg var ea)
3575  (setf (var-ea var) ea)
3576  (when (and *arm2-record-symbols* (or (typep ea 'lreg) (typep ea 'fixnum)))
3577    (let* ((start (arm2-emit-note seg :begin-variable-scope)))
3578      (push (list var (var-name var) start (close-vinsn-note start))
3579            *arm2-recorded-symbols*)))
3580  ea)
3581
3582(defun arm2-close-var (seg var)
3583  (let ((bits (nx-var-bits var)))
3584    (when (and *arm2-record-symbols*
3585               (or (logbitp $vbitspecial bits)
3586                   (not (logbitp $vbitpunted bits))))
3587      (let ((endnote (%car (%cdddr (assq var *arm2-recorded-symbols*)))))
3588        (unless endnote (compiler-bug "arm2-close-var for ~s ?" (var-name var)))
3589        (setf (vinsn-note-class endnote) :end-variable-scope)
3590        (append-dll-node (vinsn-note-label endnote) seg)))))
3591
3592(defun arm2-load-ea-p (ea)
3593  (or (typep ea 'fixnum)
3594      (typep ea 'lreg)
3595      (typep ea 'lcell)))
3596
3597(defun arm2-dbind (seg value sym)
3598  (with-arm-local-vinsn-macros (seg)
3599    (let* ((ea-p (arm2-load-ea-p value))
3600           (nil-p (unless ea-p (nx-null (setq value (nx-untyped-form value)))))
3601           (self-p (unless ea-p (and (or
3602                                      (eq (acode-operator value) (%nx1-operator bound-special-ref))
3603                                      (eq (acode-operator value) (%nx1-operator special-ref)))
3604                                     (eq (cadr value) sym)))))
3605      (cond ((eq sym '*interrupt-level*)
3606             (let* ((fixval (acode-fixnum-form-p value)))
3607               (cond ((eql fixval 0) (if *arm2-open-code-inline*
3608                                       (! bind-interrupt-level-0-inline)
3609                                       (! bind-interrupt-level-0)))
3610                     ((eql fixval -1) (if *arm2-open-code-inline*
3611                                        (! bind-interrupt-level-m1-inline)
3612                                        (! bind-interrupt-level-m1)))
3613                     (t
3614                      (if ea-p 
3615                        (arm2-store-ea seg value arm::arg_z)
3616                        (arm2-one-targeted-reg-form seg value ($ arm::arg_z)))
3617                      (! bind-interrupt-level))))
3618             (arm2-open-undo $undointerruptlevel))
3619            (t
3620             (if (or nil-p self-p)
3621               (progn
3622                 (arm2-store-immediate seg (arm2-symbol-value-cell sym) arm::arg_z)
3623                 (if nil-p
3624                   (! bind-nil)
3625                   (if (or *arm2-reckless* (eq (acode-operator value) (%nx1-operator special-ref)))
3626                     (! bind-self)
3627                     (! bind-self-boundp-check))))
3628               (progn
3629                 (if ea-p 
3630                   (arm2-store-ea seg value arm::arg_z)
3631                   (arm2-one-targeted-reg-form seg value ($ arm::arg_z)))
3632                 (arm2-store-immediate seg (arm2-symbol-value-cell sym) ($ arm::arg_y))
3633                 (! bind)))
3634             (arm2-open-undo $undospecial)))
3635      (arm2-new-vstack-lcell :special-value *arm2-target-lcell-size* 0 sym)
3636      (arm2-new-vstack-lcell :special *arm2-target-lcell-size* (ash 1 $vbitspecial) sym)
3637      (arm2-new-vstack-lcell :special-link *arm2-target-lcell-size* 0 sym)
3638      (arm2-adjust-vstack (* 3 *arm2-target-node-size*)))))
3639
3640;;; Store the contents of EA - which denotes either a vframe location
3641;;; or a hard register - in reg.
3642
3643(defun arm2-store-ea (seg ea reg)
3644  (if (typep ea 'fixnum)
3645    (if (memory-spec-p ea)
3646      (arm2-stack-to-register seg ea reg)
3647      (arm2-copy-register seg reg ea))
3648    (if (typep ea 'lreg)
3649      (arm2-copy-register seg reg ea)
3650      (if (typep ea 'lcell)
3651        (arm2-lcell-to-register seg ea reg)))))
3652
3653
3654     
3655
3656;;; Callers should really be sure that this is what they want to use.
3657(defun arm2-absolute-natural (seg vreg xfer value)
3658  (with-arm-local-vinsn-macros (seg vreg xfer)
3659    (when vreg
3660      (arm2-lri seg vreg value))
3661    (^)))
3662
3663
3664
3665(defun arm2-store-macptr (seg vreg address-reg)
3666  (with-arm-local-vinsn-macros (seg vreg)
3667    (when (arm2-for-value-p vreg)
3668      (if (logbitp vreg arm-imm-regs)
3669        (<- address-reg)
3670        (! macptr->heap vreg address-reg)))))
3671
3672(defun arm2-store-signed-longword (seg vreg imm-reg)
3673  (with-arm-local-vinsn-macros (seg vreg)
3674    (when (arm2-for-value-p vreg)
3675      (if (logbitp vreg arm-imm-regs)
3676        (<- imm-reg)
3677        (arm2-box-s32 seg vreg imm-reg)))))
3678
3679(defun arm2-store-signed-halfword (seg vreg imm-reg)
3680  (with-arm-local-vinsn-macros (seg vreg)
3681    (when (arm2-for-value-p vreg)
3682      (if (logbitp vreg arm-imm-regs)
3683        (<- imm-reg)
3684        (! s16->fixnum vreg imm-reg)))))
3685
3686
3687(defun arm2-store-unsigned-halfword (seg vreg imm-reg)
3688  (with-arm-local-vinsn-macros (seg vreg)
3689    (when (arm2-for-value-p vreg)
3690      (if (logbitp vreg arm-imm-regs)
3691        (<- imm-reg)
3692        (! u16->fixnum vreg imm-reg)))))
3693
3694
3695
3696;;; If "value-first-p" is true and both "offset" and "val" need to be
3697;;; evaluated, evaluate "val" before evaluating "offset".
3698(defun arm2-%immediate-set-ptr (seg vreg xfer  ptr offset val)
3699  (with-arm-local-vinsn-macros (seg vreg xfer)
3700    (let* ((intval (acode-absolute-ptr-p val))
3701           (offval (acode-fixnum-form-p offset))
3702           (for-value (arm2-for-value-p vreg)))
3703      (flet ((address-and-node-regs ()
3704               (if for-value
3705                 (progn
3706                   (arm2-one-targeted-reg-form seg val ($ arm::arg_z))
3707                   (progn
3708                     (if intval
3709                       (arm2-lri seg arm::imm0 intval)
3710                       (! deref-macptr arm::imm0 arm::arg_z))
3711                     (values arm::imm0 arm::arg_z)))
3712                 (values (arm2-macptr-arg-to-reg seg val ($ arm::imm0 :mode :address)) nil))))
3713
3714        (and offval (%i> (integer-length offval) 11) (setq offval nil))
3715        (if offval
3716                                        ; Easier: need one less register than in the general case.
3717          (with-imm-target () (ptr-reg :address)
3718            (arm2-one-targeted-reg-form seg ptr ptr-reg)
3719            (if intval
3720              (with-imm-target (ptr-reg) (val-target :address)
3721                (arm2-lri seg val-target intval)
3722                (! mem-set-c-address val-target ptr-reg offval)
3723                (if for-value
3724                  (<- (set-regspec-mode val-target (gpr-mode-name-value :address)))))
3725              (progn
3726                (! temp-push-unboxed-word ptr-reg)
3727                (arm2-open-undo $undostkblk)
3728                (multiple-value-bind (address node) (address-and-node-regs)
3729                  (with-imm-target (address) (ptr-reg :address)
3730                    (! temp-pop-unboxed-word ptr-reg)
3731                    (arm2-close-undo)
3732                    (! mem-set-c-address address ptr-reg offval)
3733                    (if for-value
3734                      (<- node)))))))
3735          ;; No (16-bit) constant offset.  Might still have a 32-bit
3736          ;; constant offset; might have a constant value.  Might
3737          ;; not.  Might not.  Easiest to special-case the
3738          ;; constant-value case first ...
3739          (let* ((xptr-reg nil)
3740                 (xoff-reg nil)
3741                 (xval-reg nil)
3742                 (node-arg_z nil)
3743                 (constant-offset (acode-fixnum-form-p offset)))
3744            (if intval
3745              (if constant-offset
3746                (with-imm-target () (ptr-reg :address)
3747                  (arm2-one-targeted-reg-form seg ptr ptr-reg)
3748                  (with-imm-target (ptr-reg) (off-reg :signed-natural)
3749                    (arm2-lri seg off-reg constant-offset)
3750                    (with-imm-target (ptr-reg off-reg) (val-reg :address)
3751                      (arm2-lri seg val-reg intval)
3752                      (setq xptr-reg ptr-reg
3753                            xoff-reg off-reg
3754                            xval-reg val-reg))))
3755                ;; Offset's non-constant.  Temp-push the pointer, evaluate
3756                ;; and unbox the offset, load the value, pop the pointer.
3757                (progn
3758                  (with-imm-target () (ptr-reg :address)
3759                    (arm2-one-targeted-reg-form seg ptr ptr-reg)
3760                    (! temp-push-unboxed-word ptr-reg)
3761                    (arm2-open-undo $undostkblk))
3762                  (with-imm-target () (off-reg :signed-natural)
3763                    (! fixnum->signed-natural off-reg (arm2-one-targeted-reg-form seg offset ($ arm::arg_z)))
3764                    (with-imm-target (off-reg) (val-reg :signed-natural)
3765                      (arm2-lri seg val-reg intval)
3766                      (with-imm-target (off-reg val-reg) (ptr-reg :address)
3767                        (! temp-pop-unboxed-word ptr-reg)
3768                        (arm2-close-undo)
3769                        (setq xptr-reg ptr-reg
3770                              xoff-reg off-reg
3771                              xval-reg val-reg))))))
3772              ;; No intval; maybe constant-offset.
3773              (with-imm-target () (ptr-reg :address)
3774                (arm2-one-targeted-reg-form seg ptr ptr-reg)
3775                (! temp-push-unboxed-word ptr-reg)
3776                (arm2-open-undo $undostkblk)
3777                (progn
3778                  (if (not constant-offset)
3779                    (arm2-vpush-register seg (arm2-one-untargeted-reg-form seg offset arm::arg_z)))
3780                  (multiple-value-bind (address node) (address-and-node-regs)
3781                    (with-imm-target (address) (off-reg :s32)
3782                      (if constant-offset
3783                        (arm2-lri seg off-reg constant-offset)
3784                        (with-node-temps (arm::arg_z) (temp)
3785                          (arm2-vpop-register seg temp)
3786                          (! fixnum->signed-natural off-reg temp)))
3787                      (with-imm-target (arm::imm0 off-reg) (ptr-reg :address)
3788                        (! temp-pop-unboxed-word ptr-reg)
3789                        (arm2-close-undo)
3790                        (setq xptr-reg ptr-reg
3791                              xoff-reg off-reg
3792                              xval-reg address
3793                              node-arg_z node)))))))
3794            (! mem-set-address xval-reg xptr-reg xoff-reg)
3795            (when for-value
3796              (if node-arg_z
3797                (<- node-arg_z)
3798                (<- (set-regspec-mode 
3799                     xval-reg
3800                     (gpr-mode-name-value :address)))))))
3801        (^)))))
3802 
3803(defun arm2-memory-store-displaced (seg valreg basereg displacement size)
3804  (with-arm-local-vinsn-macros (seg)
3805    (case size
3806      (8 (! mem-set-c-doubleword valreg basereg displacement))
3807      (4 (! mem-set-c-fullword valreg basereg displacement))
3808      (2 (! mem-set-c-halfword valreg basereg displacement))
3809      (1 (! mem-set-c-byte valreg basereg displacement)))))
3810
3811(defun arm2-memory-store-indexed (seg valreg basereg idxreg size)
3812  (with-arm-local-vinsn-macros (seg)
3813    (case size
3814      (8 (! mem-set-doubleword valreg basereg idxreg))
3815      (4 (! mem-set-fullword valreg basereg idxreg))
3816      (2 (! mem-set-halfword valreg basereg idxreg))
3817      (1 (! mem-set-byte valreg basereg idxreg)))))
3818     
3819(defun arm2-%immediate-store  (seg vreg xfer bits ptr offset val)
3820  (with-arm-local-vinsn-macros (seg vreg xfer)
3821    (if (eql 0 (%ilogand #xf bits))
3822      (arm2-%immediate-set-ptr seg vreg xfer  ptr offset val)
3823      (let* ((size (logand #xf bits))
3824             (nbits (ash size 3))
3825             (signed (not (logbitp 5 bits)))
3826             (intval (acode-integer-constant-p val nbits))
3827             (offval (acode-fixnum-form-p offset))
3828             (for-value (arm2-for-value-p vreg)))
3829        (declare (fixnum size))
3830        (flet ((val-to-argz-and-imm0 ()
3831                 (arm2-one-targeted-reg-form seg val ($ arm::arg_z))
3832                 (if (eq size 8)
3833                   (if signed
3834                     (! gets64)
3835                     (! getu64))
3836                   (if (eq size 4)
3837                     (if signed
3838                       (! gets32)
3839                       (! getu32))
3840                     (! fixnum->signed-natural arm::imm0 arm::arg_z)))))
3841
3842          (and offval (%i> (integer-length offval) 11) (setq offval nil))
3843          (if offval
3844                                        ; Easier: need one less register than in the general case.
3845            (with-imm-target () (ptr-reg :address)
3846              (arm2-one-targeted-reg-form seg ptr ptr-reg)
3847              (if intval
3848                (with-imm-target (ptr-reg) (val-target :s32)                   
3849                  (arm2-lri seg val-target intval)
3850                  (arm2-memory-store-displaced seg val-target ptr-reg offval size)
3851                  (if for-value
3852                    (<- (set-regspec-mode 
3853                         val-target 
3854                         (gpr-mode-name-value
3855                          (case size
3856                            (8 (if signed :s64 :u64))
3857                            (4 (if signed :s32 :u32))
3858                            (2 (if signed :s16 :u16))
3859                            (1 (if signed :s8 :u8))))))))
3860                (progn
3861                  (! temp-push-unboxed-word ptr-reg)
3862                  (arm2-open-undo $undostkblk)
3863                  (val-to-argz-and-imm0)                 
3864                  (with-imm-target (arm::imm0) (ptr-reg :address)
3865                    (! temp-pop-unboxed-word ptr-reg)
3866                    (arm2-close-undo)
3867                    (arm2-memory-store-displaced seg arm::imm0 ptr-reg offval size)                   
3868                    (if for-value
3869                      (<- arm::arg_z))))))
3870            ;; No (16-bit) constant offset.  Might still have a 32-bit constant offset;
3871            ;; might have a constant value.  Might not.  Might not.
3872            ;; Easiest to special-case the constant-value case first ...
3873            (let* ((xptr-reg nil)
3874                   (xoff-reg nil)
3875                   (xval-reg nil)
3876                   (node-arg_z nil)
3877                   (constant-offset (acode-fixnum-form-p offset)))
3878              (if intval
3879                (if constant-offset
3880                  (with-imm-target () (ptr-reg :address)
3881                    (arm2-one-targeted-reg-form seg ptr ptr-reg)
3882                    (with-imm-target (ptr-reg) (off-reg :s32)
3883                      (arm2-lri seg off-reg constant-offset)
3884                      (with-imm-target (ptr-reg off-reg) (val-reg :s32)
3885                        (arm2-lri seg val-reg intval)
3886                        (setq xptr-reg ptr-reg
3887                              xoff-reg off-reg
3888                              xval-reg val-reg))))
3889                                        ; Offset's non-constant.  Temp-push the pointer, evaluate
3890                                        ; and unbox the offset, load the value, pop the pointer.
3891                  (progn
3892                    (with-imm-target () (ptr-reg :address)
3893                      (arm2-one-targeted-reg-form seg ptr ptr-reg)
3894                      (! temp-push-unboxed-word ptr-reg)
3895                      (arm2-open-undo $undostkblk))
3896                    (with-imm-target () (off-reg :s32)
3897                      (! fixnum->signed-natural off-reg (arm2-one-targeted-reg-form seg offset ($ arm::arg_z)))
3898                      (with-imm-target (off-reg) (val-reg :s32)
3899                        (arm2-lri seg val-reg intval)
3900                        (with-imm-target (off-reg val-reg) (ptr-reg :address)
3901                          (! temp-pop-unboxed-word ptr-reg)
3902                          (arm2-close-undo)
3903                          (setq xptr-reg ptr-reg
3904                                xoff-reg off-reg
3905                                xval-reg val-reg))))))
3906                ;; No intval; maybe constant-offset.
3907                (with-imm-target () (ptr-reg :address)
3908                  (arm2-one-targeted-reg-form seg ptr ptr-reg)
3909                  (! temp-push-unboxed-word ptr-reg)
3910                  (arm2-open-undo $undostkblk)
3911                  (progn
3912                    (if (not constant-offset)
3913                      (arm2-vpush-register seg (arm2-one-untargeted-reg-form seg offset arm::arg_z)))
3914                    (val-to-argz-and-imm0)
3915                    (with-imm-target (arm::imm0) (off-reg :signed-natural)
3916                      (if constant-offset
3917                        (arm2-lri seg off-reg constant-offset)
3918                        (with-node-temps (arm::arg_z) (temp)
3919                          (arm2-vpop-register seg temp)
3920                          (! fixnum->signed-natural off-reg temp)))
3921                      (with-imm-target (arm::imm0 off-reg) (ptr-reg :address)
3922                        (! temp-pop-unboxed-word ptr-reg)
3923                        (arm2-close-undo)
3924                        (setq xptr-reg ptr-reg
3925                              xoff-reg off-reg
3926                              xval-reg arm::imm0
3927                              node-arg_z t))))))
3928              (arm2-memory-store-indexed seg xval-reg xptr-reg xoff-reg size)
3929              (when for-value
3930                (if node-arg_z
3931                  (<- arm::arg_z)
3932                  (<- (set-regspec-mode 
3933                       xval-reg
3934                       (gpr-mode-name-value
3935                        (case size
3936                          (8 (if signed :s64 :u64))
3937                          (4 (if signed :s32 :u32))
3938                          (2 (if signed :s16 :u16))
3939                          (1 (if signed :s8 :u8))))))))))
3940          (^))))))
3941
3942
3943
3944
3945
3946(defun arm2-encoding-undo-count (encoding)
3947 (svref encoding 0))
3948
3949(defun arm2-encoding-cstack-depth (encoding)    ; hardly ever interesting
3950  (svref encoding 1))
3951
3952(defun arm2-encoding-vstack-depth (encoding)
3953  (svref encoding 2))
3954
3955(defun arm2-encoding-vstack-top (encoding)
3956  (svref encoding 3))
3957
3958(defun arm2-encode-stack ()
3959  (vector *arm2-undo-count* *arm2-cstack* *arm2-vstack* *arm2-top-vstack-lcell*))
3960
3961(defun arm2-decode-stack (encoding)
3962  (values (arm2-encoding-undo-count encoding)
3963          (arm2-encoding-cstack-depth encoding)
3964          (arm2-encoding-vstack-depth encoding)
3965          (arm2-encoding-vstack-top encoding)))
3966
3967(defun arm2-equal-encodings-p (a b)
3968  (dotimes (i 3 t)
3969    (unless (eq (svref a i) (svref b i)) (return))))
3970
3971(defun arm2-open-undo (&optional (reason $undocatch) (curstack (arm2-encode-stack)))
3972  (set-fill-pointer 
3973   *arm2-undo-stack*
3974   (set-fill-pointer *arm2-undo-because* *arm2-undo-count*))
3975  (vector-push-extend curstack *arm2-undo-stack*)
3976  (vector-push-extend reason *arm2-undo-because*)
3977  (setq *arm2-undo-count* (%i+ *arm2-undo-count* 1)))
3978
3979(defun arm2-close-undo (&aux
3980                        (new-count (%i- *arm2-undo-count* 1))
3981                        (i (aref *arm2-undo-stack* new-count)))
3982  (multiple-value-setq (*arm2-undo-count* *arm2-cstack* *arm2-vstack* *arm2-top-vstack-lcell*)
3983    (arm2-decode-stack i))
3984  (set-fill-pointer 
3985   *arm2-undo-stack*
3986   (set-fill-pointer *arm2-undo-because* new-count)))
3987
3988
3989
3990
3991
3992;;; "Trivial" means can be evaluated without allocating or modifying registers.
3993;;; Interim definition, which will probably stay here forever.
3994(defun arm2-trivial-p (form &aux op bits)
3995  (setq form (nx-untyped-form form))
3996  (and
3997   (consp form)
3998   (not (eq (setq op (%car form)) (%nx1-operator call)))
3999   (or
4000    (nx-null form)
4001    (nx-t form)
4002    (eq op (%nx1-operator simple-function))
4003    (eq op (%nx1-operator fixnum))
4004    (eq op (%nx1-operator immediate))
4005    #+nil
4006    (eq op (%nx1-operator bound-special-ref))
4007    (and (or (eq op (%nx1-operator inherited-arg)) 
4008             (eq op (%nx1-operator lexical-reference)))
4009         (or (%ilogbitp $vbitpunted (setq bits (nx-var-bits (cadr form))))
4010             (neq (%ilogior (%ilsl $vbitclosed 1) (%ilsl $vbitsetq 1))
4011                  (%ilogand (%ilogior (%ilsl $vbitclosed 1) (%ilsl $vbitsetq 1)) bits)))))))
4012
4013(defun arm2-lexical-reference-p (form)
4014  (when (acode-p form)
4015    (let ((op (acode-operator (setq form (acode-unwrapped-form-value form)))))
4016      (when (or (eq op (%nx1-operator lexical-reference))
4017                (eq op (%nx1-operator inherited-arg)))
4018        (%cadr form)))))
4019
4020
4021
4022(defun arm2-ref-symbol-value (seg vreg xfer sym check-boundp)
4023  (declare (ignorable check-boundp))
4024  (setq check-boundp (not *arm2-reckless*))
4025  (with-arm-local-vinsn-macros (seg vreg xfer)
4026    (when (or check-boundp vreg)
4027      (unless vreg (setq vreg ($ arm::arg_z)))
4028      (if (eq sym '*interrupt-level*)
4029          (ensuring-node-target (target vreg)
4030            (! ref-interrupt-level target))
4031          (if *arm2-open-code-inline*
4032            (ensuring-node-target (target vreg)
4033              (with-node-target (target) src
4034                (let* ((vcell (arm2-symbol-value-cell sym))
4035                       (reg (arm2-register-constant-p vcell)))
4036                  (if reg
4037                    (setq src reg)
4038                    (arm2-store-immediate seg vcell src)))
4039                (if check-boundp
4040                  (! ref-symbol-value-inline target src)
4041                  (! %ref-symbol-value-inline target src))))
4042            (let* ((src ($ arm::arg_z))
4043                   (dest ($ arm::arg_z)))
4044              (arm2-store-immediate seg (arm2-symbol-value-cell sym) src)
4045              (if check-boundp
4046                (! ref-symbol-value dest src)
4047                (! %ref-symbol-value dest src))
4048              (<- dest)))))
4049    (^)))
4050
4051#|
4052(defun arm2-ref-symbol-value (seg vreg xfer sym check-boundp) 
4053  (with-arm-local-vinsn-macros (seg vreg xfer)
4054    (when vreg
4055      (if (eq sym '*interrupt-level*)
4056        (ensuring-node-target (target vreg)
4057          (! ref-interrupt-level target))
4058        (let* ((src ($ arm::arg_z))
4059               (dest ($ arm::arg_z)))
4060          (arm2-store-immediate seg (arm2-symbol-value-cell sym) src)
4061          (if check-boundp
4062            (! ref-symbol-value dest src)
4063            (! %ref-symbol-value dest src))
4064          (<- dest))))
4065    (^)))
4066||#
4067
4068;;; Should be less eager to box result
4069(defun arm2-extract-charcode (seg vreg xfer char safe)
4070  (with-arm-local-vinsn-macros (seg vreg xfer)
4071    (let* ((src (arm2-one-untargeted-reg-form seg char arm::arg_z)))
4072      (when safe
4073        (! trap-unless-character src))
4074      (if vreg
4075        (ensuring-node-target (target vreg)
4076          (! character->fixnum target src)))
4077      (^))))
4078 
4079
4080(defun arm2-reference-list (seg vreg xfer listform safe refcdr)
4081  (if (arm2-form-typep listform 'list)
4082    (setq safe nil))                    ; May also have been passed as NIL.
4083  (with-arm-local-vinsn-macros (seg vreg xfer)
4084    (let* ((src (arm2-one-untargeted-reg-form seg listform arm::arg_z)))
4085      (when safe
4086        (! trap-unless-list src))
4087      (if vreg
4088        (ensuring-node-target (target vreg)
4089          (if refcdr
4090            (! %cdr target src)
4091            (! %car target src))))
4092      (^))))
4093
4094
4095
4096
4097
4098
4099
4100(defun arm2-misc-byte-count (subtag element-count)
4101  (funcall (arch::target-array-data-size-function
4102            (backend-target-arch *target-backend*))
4103           subtag element-count))
4104
4105
4106;;; The naive approach is to vpush all of the initforms, allocate the
4107;;; miscobj, then sit in a loop vpopping the values into the vector.
4108;;; That's "naive" when most of the initforms in question are
4109;;; "side-effect-free" (constant references or references to un-SETQed
4110;;; lexicals), in which case it makes more sense to just store the
4111;;; things into the vector cells, vpushing/ vpopping only those things
4112;;; that aren't side-effect-free.  (It's necessary to evaluate any
4113;;; non-trivial forms before allocating the miscobj, since that
4114;;; ensures that the initforms are older (in the EGC sense) than it
4115;;; is.)  The break-even point space-wise is when there are around 3
4116;;; non-trivial initforms to worry about.
4117
4118
4119(defun arm2-allocate-initialized-gvector (seg vreg xfer subtag initforms)
4120  (with-arm-local-vinsn-macros (seg vreg xfer)
4121    (if (null vreg)
4122      (dolist (f initforms) (arm2-form seg nil nil f))
4123      (let* ((*arm2-vstack* *arm2-vstack*)
4124             (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*)
4125             (arch (backend-target-arch *target-backend*))
4126             (n (length initforms))
4127             (nntriv (let* ((count 0)) 
4128                       (declare (fixnum count))
4129                       (dolist (f initforms count) 
4130                         (unless (arm-side-effect-free-form-p f)
4131                           (incf count)))))
4132             (header (arch::make-vheader n subtag)))
4133        (declare (fixnum n nntriv))
4134        (cond ( (or *arm2-open-code-inline* (> nntriv 3))
4135               (arm2-formlist seg initforms nil)
4136               (arm2-lri seg arm::imm0 header)
4137               (! %arm-gvector vreg arm::imm0 (ash n (arch::target-word-shift arch))))
4138              (t
4139               (let* ((pending ())
4140                      (vstack *arm2-vstack*))
4141                 (declare (fixnum vstack))
4142                 (dolist (form initforms)
4143                   (if (arm-side-effect-free-form-p form)
4144                     (push form pending)
4145                     (progn
4146                       (push nil pending)
4147                       (arm2-vpush-register seg (arm2-one-untargeted-reg-form seg form arm::arg_z)))))
4148                 (arm2-lri seg arm::imm0 header)
4149                 (ensuring-node-target (target vreg)
4150                   (! %alloc-misc-fixed target arm::imm0 (ash n (arch::target-word-shift arch)))
4151                   (with-node-temps (target) (nodetemp)
4152                     (do* ((forms pending (cdr forms))
4153                           (index (1- n) (1- index))
4154                           (pushed-cell (+ vstack (the fixnum (ash nntriv (arch::target-word-shift arch))))))
4155                          ((null forms))
4156                       (declare (list forms) (fixnum pushed-cell))
4157                       (let* ((form (car forms))
4158                              (reg nodetemp))
4159                         (if form
4160                           (setq reg (arm2-one-untargeted-reg-form seg form nodetemp))
4161                           (progn
4162                             (decf pushed-cell *arm2-target-node-size*)
4163                             (arm2-stack-to-register seg (arm2-vloc-ea pushed-cell) nodetemp)))
4164                         (! misc-set-c-node reg target index)))))
4165                 (! vstack-discard nntriv))
4166               ))))
4167     (^)))
4168
4169;;; Heap-allocated constants -might- need memoization: they might be newly-created,
4170;;; as in the case of synthesized toplevel functions in .pfsl files.
4171(defun arm2-acode-needs-memoization (valform)
4172  (if (arm2-form-typep valform 'fixnum)
4173    nil
4174    (let* ((val (acode-unwrapped-form-value valform)))
4175      (if (or (nx-t val)
4176              (nx-null val)
4177              (and (acode-p val)
4178                   (let* ((op (acode-operator val)))
4179                     (or (eq op (%nx1-operator fixnum)) #|(eq op (%nx1-operator immediate))|#))))
4180        nil
4181        t))))
4182
4183(defun arm2-modify-cons (seg vreg xfer ptrform valform safe setcdr returnptr)
4184  (if (arm2-form-typep ptrform 'cons)
4185    (setq safe nil))                    ; May also have been passed as NIL.
4186  (with-arm-local-vinsn-macros (seg vreg xfer)
4187    (multiple-value-bind (ptr-vreg val-vreg) (arm2-two-targeted-reg-forms seg ptrform ($ arm::arg_y) valform ($ arm::arg_z))
4188      (when safe
4189        (! trap-unless-cons ptr-vreg))
4190      (if setcdr
4191        (! call-subprim-2 ($ arm::arg_z) (subprim-name->offset '.SPrplacd) ptr-vreg val-vreg)
4192        (! call-subprim-2 ($ arm::arg_z) (subprim-name->offset '.SPrplaca) ptr-vreg val-vreg))
4193      (if returnptr
4194        (<- ptr-vreg)
4195        (<- val-vreg))
4196      (^))))
4197
4198
4199
4200(defun arm2-find-nilret-label ()
4201  (dolist (l *arm2-nilret-labels*)
4202    (destructuring-bind (label vsp csp register-restore-count register-restore-ea &rest agenda) l
4203      (and (or (and (eql 0 register-restore-count)
4204                    (or (not (eql 0 vsp))
4205                        (eq vsp *arm2-vstack*)))
4206                (and 
4207                 (eq register-restore-count *arm2-register-restore-count*)
4208                 (eq vsp *arm2-vstack*)))
4209           (or agenda (eq csp *arm2-cstack*))
4210           (eq register-restore-ea *arm2-register-restore-ea*)
4211           (eq (%ilsr 1 (length agenda)) *arm2-undo-count*)
4212           (dotimes (i (the fixnum *arm2-undo-count*) t) 
4213             (unless (and (eq (pop agenda) (aref *arm2-undo-because* i))
4214                          (eq (pop agenda) (aref *arm2-undo-stack* i)))
4215               (return)))
4216           (return label)))))
4217
4218(defun arm2-record-nilret-label ()
4219  (let* ((lab (backend-get-next-label))
4220         (info nil))
4221    (dotimes (i (the fixnum *arm2-undo-count*))
4222      (push (aref *arm2-undo-because* i) info)
4223      (push (aref *arm2-undo-stack* i) info))
4224    (push (cons
4225                 lab 
4226                 (cons
4227                  *arm2-vstack*
4228                  (cons 
4229                   *arm2-cstack*
4230                   (cons
4231                    *arm2-register-restore-count*
4232                    (con