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

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

Map frontend condition to arm condition, true-p, not to arm-condition, t.
(Complementing/negating conditions depends on this, as written.)
Compare single-floats as single-floats.

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