source: trunk/source/compiler/ARM/arm-vinsns.lisp @ 15111

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

ARM-specific changes, mostly.

When running lisp code (in almost all cases), keep the constant 0.0d0
in the d7 register (and therefore 0.0s0 in s14 and s15). We use d7 as
a vector header when saving non-volatile FPRs on the stack; we
actually only modify s14, so we now restore s14 after it's been used
this way. The value used in the header in lisp and kernel code is
loaded from PC-relative memory, which means that we no longer use
fmsr/fmdrr or similar instructions.

When starting a lisp thread or entering one via a callback, initialize
d7.

This all basically means that we can get 0.0[d|s]0 into an FPR (or
exploit the fact that it's already in one) a bit easier, and that's
generally a good thing. It's an ABI change, which means that the
FASL and image versions (for the ARM port only) changed; new binaries
are included in this commit.

The kernel changes to support the use of d7 are mostly pretty obvious.
In working on them, I noticed that "local labels" and "macro labels"
were in the same namespace, and we were only avoiding conflicts by
accident. For 10 years or so. (I also noticed that GAS doesn't fully
support PC-relative operands, so did that by hand.)

File size: 122.2 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2010 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18
19(in-package "CCL")
20
21(eval-when (:compile-toplevel :load-toplevel :execute)
22  (require "VINSN")
23  (require "ARM-BACKEND"))
24
25(eval-when (:compile-toplevel :execute)
26  (require "ARMENV"))
27
28(defmacro define-arm-vinsn (vinsn-name (results args &optional temps) &body body)
29  (%define-vinsn *arm-backend* vinsn-name results args temps body))
30
31
32;;; Non-volatile FPRs.
33(define-arm-vinsn (push-nvfprs :push :multiple :doubleword :csp :predicatable)
34    (()
35     ((n :u16const)
36      (header :u16const))
37     ((d7 (:double-float #.arm::d7))))
38  (flds s14 (:= :header))
39  (fstmdbd d7 (:! arm::sp) (:apply + n 1))
40  (fcpys single-float-zero s15)
41  (:data)
42  :header
43  (:word header)
44  (:code))
45
46(define-arm-vinsn (pop-nvfprs :push :multiple :doubleword :csp :predicatable)
47    (()
48     ((n :u16const))
49     ((d7 (:double-float #.arm::d7))))
50  (fldmiad d7 (:! arm::sp) (:apply + n 1))
51  (fcpys single-float-zero s15))
52
53(define-arm-vinsn data-section (()
54                                ())
55  (:data))
56
57(define-arm-vinsn code-section (()
58                                ())
59  (:code))
60
61
62;;; Index "scaling" and constant-offset misc-ref vinsns.
63
64(define-arm-vinsn (scale-node-misc-index :predicatable)
65    (((dest :u32))
66     ((idx :imm) ; A fixnum
67      )
68     ())
69  (add dest idx (:$ arm::misc-data-offset)))
70
71(define-arm-vinsn (scale-32bit-misc-index :predicatable)
72    (((dest :u32))
73     ((idx :imm)                        ; A fixnum
74      )
75     ())
76  (add dest idx (:$ arm::misc-data-offset)))
77
78(define-arm-vinsn (scale-16bit-misc-index :predicatable)
79    (((dest :u32))
80     ((idx :imm)                        ; A fixnum
81      )
82     ())
83  (mov  dest (:lsr idx (:$ 1)))
84  (add dest dest (:$ arm::misc-data-offset)))
85
86(define-arm-vinsn (scale-8bit-misc-index :predicatable)
87    (((dest :u32))
88     ((idx :imm)                        ; A fixnum
89      )
90     ())
91  (mov dest (:lsr idx (:$ 2)))
92  (add dest dest (:$ arm::misc-data-offset)))
93
94(define-arm-vinsn (scale-64bit-misc-index :predicatable)
95    (((dest :u32))
96     ((idx :imm)                        ; A fixnum
97      )
98     ())
99  (add dest idx idx)
100  (add dest dest (:$ arm::misc-dfloat-offset)))
101
102
103(define-arm-vinsn (scale-1bit-misc-index :predicatable)
104    (((word-index :u32)
105      (bitnum :u8))                     ; (unsigned-byte 5)
106     ((idx :imm)                        ; A fixnum
107      )
108     )
109  (mov word-index (:lsr idx (:$ arm::fixnumshift)))
110  (and bitnum word-index (:$ 31))
111  (mov word-index (:lsr word-index (:$ 5)))
112  (mov word-index (:lsl word-index (:$ arm::word-shift)))
113  (add word-index word-index (:$ arm::misc-data-offset)))
114
115
116
117(define-arm-vinsn (misc-ref-u32 :predicatable)
118    (((dest :u32))
119     ((v :lisp)
120      (scaled-idx :u32))
121     ())
122  (ldr dest (:+@ v scaled-idx)))
123
124
125(define-arm-vinsn (misc-ref-c-u32 :predicatable)
126    (((dest :u32))
127     ((v :lisp)
128      (idx :u32const))
129     ())
130  (ldr dest (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))))
131
132(define-arm-vinsn (misc-ref-s32 :predicatable)
133    (((dest :s32))
134     ((v :lisp)
135      (scaled-idx :u32))
136     ())
137  (ldr dest (:+@ v  scaled-idx)))
138
139(define-arm-vinsn (misc-ref-c-s32 :predicatable)
140    (((dest :s32))
141     ((v :lisp)
142      (idx :u32const))
143     ())
144  (ldr dest (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))))
145
146
147(define-arm-vinsn (misc-set-c-u32 :predicatable)
148    (()
149     ((val :u32)
150      (v :lisp)
151      (idx :u32const)))
152  (str val (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))))
153
154(define-arm-vinsn (misc-set-c-s32 :predicatable)
155    (()
156     ((val :s32)
157      (v :lisp)
158      (idx :u32const)))
159  (str val (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))))
160
161(define-arm-vinsn (misc-set-u32 :predicatable)
162    (()
163     ((val :u32)
164      (v :lisp)
165      (scaled-idx :u32)))
166  (str val (:+@ v scaled-idx)))
167
168(define-arm-vinsn (misc-set-s32 :predicatable)
169    (()
170     ((val :s32)
171      (v :lisp)
172      (scaled-idx :u32)))
173  (str val (:+@ v scaled-idx)))
174
175                             
176(define-arm-vinsn (misc-ref-single-float :predicatable :sets-lr)
177    (((dest :single-float))
178     ((v :lisp)
179      (scaled-idx :u32)))
180  (add lr v scaled-idx)
181  (flds dest (:@ lr (:$ 0)))
182  (mov lr (:$ 0)))
183
184(define-arm-vinsn (misc-ref-c-single-float :predicatable :sets-lr)
185    (((dest :single-float))
186     ((v :lisp)
187      (idx :u32const))
188     ())
189  (add lr v (:$ arm::misc-data-offset))
190  (flds dest (:@ lr (:$ (:apply ash idx 2))))
191  (mov lr (:$ 0)))
192
193(define-arm-vinsn (misc-ref-double-float :predicatable :sets-lr)
194    (((dest :double-float))
195     ((v :lisp)
196      (unscaled-idx :imm)))
197  (add arm::lr v (:$ arm::misc-dfloat-offset))
198  (add arm::lr arm::lr (:lsl unscaled-idx (:$ 1)))
199  (fldd dest (:@ arm::lr (:$ 0)))
200  (mov lr (:$ 0)))
201
202
203
204
205(define-arm-vinsn (misc-ref-c-double-float :predicatable :sets-lr)
206    (((dest :double-float))
207     ((v :lisp)
208      (idx :u32const)))
209  (add lr v (:$ arm::double-float.value))
210  (fldd dest (:@ lr (:$ (:apply ash idx 3))))
211  (mov lr (:$ 0)))
212
213(define-arm-vinsn (misc-set-c-double-float :predicatable :sets-lr)
214    (((val :double-float))
215     ((v :lisp)
216      (idx :u32const)))
217  (add lr v (:$ arm::double-float.value))
218  (fstd val (:@ lr (:$ (:apply ash idx 3))))
219  (mov lr (:$ 0)))
220
221(define-arm-vinsn (misc-set-double-float :predicatable :sets-lr)
222    (()
223     ((val :double-float)
224      (v :lisp)
225      (unscaled-idx :imm)))             ; a fixnum
226  (add lr v (:$ arm::misc-dfloat-offset))
227  (add lr lr (:lsl unscaled-idx (:$ 1)))
228  (fstd val (:@ lr (:$ 0)))
229  (mov lr (:$ 0)))
230
231(define-arm-vinsn (misc-set-c-single-float :predicatable)
232    (()
233     ((val :single-float)
234      (v :lisp)
235      (idx :u32const)))
236  (add lr v (:$ arm::misc-data-offset))
237  (fsts val (:@ lr (:$ (:apply ash idx 2))))
238  (mov lr (:$ 0)))
239
240
241
242
243(define-arm-vinsn (misc-set-single-float :predicatable :sets-lr)
244    (()
245     ((val :single-float)
246      (v :lisp)
247      (scaled-idx :u32)))
248  (add arm::lr v scaled-idx)
249  (fsts val (:@ arm::lr (:$ 0)))
250  (mov lr (:$ 0)))
251
252
253(define-arm-vinsn (misc-ref-u16 :predicatable)
254    (((dest :u16))
255     ((v :lisp)
256      (scaled-idx :u32))
257     ())
258  (ldrh dest (:+@ v scaled-idx)))
259
260(define-arm-vinsn (misc-ref-c-u16 :predicatable)
261    (((dest :u16))
262     ((v :lisp)
263      (idx :u32const))
264     ())
265  (ldrh dest (:+@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1))))))
266
267(define-arm-vinsn (misc-set-c-u16 :predicatable)
268    (((val :u16))
269     ((v :lisp)
270      (idx :u32const))
271     ())
272  (strh val (:+@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1))))))
273
274(define-arm-vinsn (misc-set-u16 :predicatable)
275    (((val :u16))
276     ((v :lisp)
277      (scaled-idx :s32)))
278  (strh val (:+@ v scaled-idx)))
279
280(define-arm-vinsn misc-ref-s16  (((dest :s16))
281                                 ((v :lisp)
282                                  (scaled-idx :u32))
283                                 ())
284  (ldrsh dest (:@ v scaled-idx)))
285
286(define-arm-vinsn (misc-ref-c-s16 :predicatable)
287    (((dest :s16))
288     ((v :lisp)
289      (idx :u32const))
290     ())
291  (ldrsh dest (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1))))))
292
293
294(define-arm-vinsn (misc-set-c-s16 :predicatable)
295    (((val :s16))
296     ((v :lisp)
297      (idx :u32const))
298     ())
299  (strh val (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1))))))
300
301(define-arm-vinsn (misc-set-s16 :predicatable)
302    (((val :s16))
303     ((v :lisp)
304      (scaled-idx :s32)))
305  (strh val (:@ v scaled-idx)))
306
307(define-arm-vinsn (misc-ref-u8 :predicatable)
308    (((dest :u8))
309     ((v :lisp)
310      (scaled-idx :u32))
311     ())
312  (ldrb dest (:@ v scaled-idx)))
313
314(define-arm-vinsn (misc-ref-c-u8 :predicatable)
315    (((dest :u8))
316     ((v :lisp)
317      (idx :u32const))
318     ())
319  (ldrb dest (:@ v (:$ (:apply + arm::misc-data-offset idx)))))
320
321(define-arm-vinsn (misc-set-c-u8 :predicatable)
322    (((val :u8))
323     ((v :lisp)
324      (idx :u32const))
325     ())
326  (strb val (:@ v (:$ (:apply + arm::misc-data-offset idx)))))
327
328(define-arm-vinsn (misc-set-u8 :predicatable)
329    (((val :u8))
330     ((v :lisp)
331      (scaled-idx :u32))
332     ())
333  (strb val (:@ v scaled-idx)))
334
335(define-arm-vinsn (misc-ref-s8 :predicatable)
336    (((dest :s8))
337     ((v :lisp)
338      (scaled-idx :u32))
339     ())
340  (ldrsb dest (:@ v scaled-idx)))
341
342(define-arm-vinsn (misc-ref-c-s8 :predicatable)
343    (((dest :s8))
344     ((v :lisp)
345      (idx :u32const))
346     ())
347  (ldrsb dest (:@ v (:$ (:apply + arm::misc-data-offset idx)))))
348
349(define-arm-vinsn (misc-set-c-s8 :predicatable)
350    (((val :s8))
351     ((v :lisp)
352      (idx :u32const))
353     ())
354  (strb val (:@ v (:$ (:apply + arm::misc-data-offset idx)))))
355
356(define-arm-vinsn (misc-set-s8 :predicatable)
357    (((val :s8))
358     ((v :lisp)
359      (scaled-idx :u32))
360     ())
361  (strb val (:@ v scaled-idx)))
362
363
364(define-arm-vinsn (misc-ref-c-bit :predicatable)
365    (((dest :u8))
366     ((v :lisp)
367      (idx :u32const))
368     ())
369  (ldr dest (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash (:apply ash idx -5) arm::word-shift)))))
370  (mov dest (:lsr dest (:$ (:apply logand idx #x1f))))
371  (and dest dest (:$ 1)))
372
373(define-arm-vinsn (misc-ref-c-bit-fixnum :predicatable)
374    (((dest :imm))
375     ((v :lisp)
376      (idx :u32const))
377     ((temp :u32)))
378  (ldr temp (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash (:apply ash idx -5) arm::word-shift)))))
379  (mov temp (:ror temp (:$ (:apply logand #x1f (:apply - (:apply logand idx #x1f) arm::fixnumshift)))))
380  (and dest temp (:$ arm::fixnumone)))
381
382
383(define-arm-vinsn (misc-ref-node :predicatable)
384    (((dest :lisp))
385     ((v :lisp)
386      (scaled-idx :s32))
387     ())
388  (ldr dest (:@ v scaled-idx)))
389
390
391(define-arm-vinsn (misc-ref-c-node :predicatable)
392    (((dest :lisp))
393     ((v :lisp)
394      (idx :s16const))
395     ())
396  (ldr dest (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))))
397
398(define-arm-vinsn (misc-set-node :predicatable)
399    (()
400     ((val :lisp)
401      (v :lisp)
402      (scaled-idx :u32)))
403  (str val (:@ v scaled-idx)))
404
405;;; This should only be used for initialization (when the value being
406;;; stored is known to be older than the vector V.)
407(define-arm-vinsn (misc-set-c-node :predicatable)
408    (()
409     ((val :lisp)
410      (v :lisp)
411      (idx :s16const))
412     ())
413  (str val (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))))
414
415
416(define-arm-vinsn (misc-element-count-fixnum :predicatable)
417    (((dest :imm))
418     ((v :lisp))
419     ((temp :u32)))
420  (ldr temp (:@ v (:$ arm::misc-header-offset)))
421  (bic temp temp (:$ arm::subtag-mask))
422  (mov dest (:lsr temp (:$ (- arm::num-subtag-bits arm::fixnum-shift)))))
423
424(define-arm-vinsn check-misc-bound (()
425                                    ((idx :imm)
426                                     (v :lisp))
427                                    ((temp :u32)))
428  (ldr temp (:@ v (:$ arm::misc-header-offset)))
429  (bic temp temp (:$ arm::subtag-mask))
430  (cmp idx (:lsr temp (:$ (- arm::num-subtag-bits arm::fixnum-shift))))
431  (blo :ok)
432  (uuo-error-vector-bounds idx v)
433  :ok)
434
435(define-arm-vinsn (2d-unscaled-index :predicatable)
436    (((dest :imm)
437      (dim1 :u32))
438     ((dim1 :u32)
439      (i :imm)
440      (j :imm)))
441  (mla dest i dim1 j))
442
443;; dest <- (+ (* i dim1 dim2) (* j dim2) k)
444
445(define-arm-vinsn (3d-unscaled-index :predicatable)
446    (((dest :imm)
447      (dim1 :u32)
448      (dim2 :u32))
449     ((dim1 :u32)
450      (dim2 :u32)
451      (i :imm)
452      (j :imm)
453      (k :imm)))
454  (mul dim1 dim1 dim2)
455  (mla dim2 j dim2 k)
456  (mla dest dim1 i dim2))
457
458(define-arm-vinsn (2d-dim1 :predicatable)
459    (((dest :u32))
460     ((header :lisp)))
461  (ldr dest (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))))))
462  (mov dest (:asr dest (:$ arm::fixnumshift))))
463
464
465
466(define-arm-vinsn (3d-dims :predicatable)
467    (((dim1 :u32)
468      (dim2 :u32))
469     ((header :lisp)))
470  (ldr dim1 (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))))))
471  (ldr dim2 (:@ header (:$ (+ arm::misc-data-offset (* 4 (+ 2 arm::arrayH.dim0-cell))))))
472  (mov dim1 (:asr dim1 (:$ arm::fixnumshift)))
473  (mov dim2 (:asr dim2 (:$ arm::fixnumshift))))
474
475;; Return dim1 (unboxed)
476(define-arm-vinsn check-2d-bound (((dim :u32))
477                                  ((i :imm)
478                                   (j :imm)
479                                   (header :lisp)))
480  (ldr dim (:@ header (:$ (+ arm::misc-data-offset (* 4 arm::arrayH.dim0-cell)))))
481  (cmp i dim)
482  (blo :ok1)
483  (uuo-error-array-bounds  i header)
484  :ok1
485  (ldr dim (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))))))
486  (cmp j dim)
487  (blo :ok2)
488  (uuo-error-array-bounds  j header)
489  :ok2
490  (mov dim (:asr dim (:$ arm::fixnumshift))))
491
492(define-arm-vinsn check-3d-bound (((dim1 :u32)
493                                   (dim2 :u32))
494                                  ((i :imm)
495                                   (j :imm)
496                                   (k :imm)
497                                   (header :lisp)))
498  (ldr dim1 (:@ header (:$ (+ arm::misc-data-offset (* 4 arm::arrayH.dim0-cell)))))
499  (cmp i dim1)
500  (blo :ok1)
501  (uuo-error-array-bounds  i header)
502  :ok1
503  (ldr dim1 (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))))))
504  (cmp j dim1)
505  (blo :ok2)
506  (uuo-error-array-bounds  i header)
507  :ok2
508  (ldr dim2 (:@ header (:$ (+ arm::misc-data-offset (* 4 (+ 2 arm::arrayH.dim0-cell))))))
509  (cmp k dim2)
510  (blo :ok3)
511  (uuo-error-array-bounds  i header)
512  :ok3
513  (mov dim1 (:asr dim1 (:$ arm::fixnumshift)))
514  (mov dim2 (:asr dim2 (:$ arm::fixnumshift))))
515
516(define-arm-vinsn (array-data-vector-ref :predicatable)
517    (((dest :lisp))
518     ((header :lisp)))
519  (ldr dest (:@ header (:$ arm::arrayH.data-vector))))
520
521 
522(define-arm-vinsn (node-slot-ref :predicatable)
523    (((dest :lisp))
524     ((node :lisp)
525      (cellno :u32const)))
526  (ldr dest (:@ node (:$ (:apply + arm::misc-data-offset (:apply ash cellno 2))))))
527
528
529
530(define-arm-vinsn  %slot-ref (((dest :lisp))
531                              ((instance (:lisp (:ne dest)))
532                               (index :lisp))
533                              ((scaled :u32)))
534  (add scaled index (:$ arm::misc-data-offset))
535  (ldr dest (:@ instance scaled))
536  (cmp dest (:$ arm::slot-unbound-marker))
537  (bne :ok)
538  (uuo-error-slot-unbound  dest instance index)
539  :ok)
540
541
542;;; Untagged memory reference & assignment.
543
544(define-arm-vinsn (mem-ref-c-fullword :predicatable)
545    (((dest :u32))
546     ((src :address)
547      (index :s16const)))
548  (ldr dest (:@ src (:$ index))))
549
550
551(define-arm-vinsn (mem-ref-c-signed-fullword :predicatable)
552    (((dest :s32))
553     ((src :address)
554      (index :s16const)))
555  (ldr dest (:@ src (:$ index))))
556
557
558(define-arm-vinsn (mem-ref-c-natural :predicatable)
559    (((dest :u32))
560     ((src :address)
561      (index :s16const)))
562  (ldr dest (:@ src (:$ index))))
563 
564
565(define-arm-vinsn (mem-ref-fullword :predicatable)
566    (((dest :u32))
567     ((src :address)
568      (index :s32)))
569  (ldr dest (:@ src index)))
570
571(define-arm-vinsn (mem-ref-signed-fullword :predicatable)
572    (((dest :u32))
573     ((src :address)
574      (index :s32)))
575  (ldr dest (:@ src index)))
576
577(define-arm-vinsn (mem-ref-natural :predicatable)
578    (((dest :u32))
579     ((src :address)
580      (index :s32)))
581  (ldr dest (:@ src index)))
582
583
584(define-arm-vinsn (mem-ref-c-u16 :predicatable)
585    (((dest :u16))
586     ((src :address)
587      (index :s16const)))
588  (ldrh dest (:@ src (:$ index))))
589
590
591(define-arm-vinsn (mem-ref-u16 :predicatable)
592    (((dest :u16))
593     ((src :address)
594      (index :s32)))
595  (ldrh dest (:@ src index)))
596
597
598
599(define-arm-vinsn (mem-ref-c-s16 :predicatable)
600    (((dest :s16))
601     ((src :address)
602      (index :s16const)))
603  (ldrsh dest (:@ src (:$ index))))
604
605(define-arm-vinsn (mem-ref-s16 :predicatable)
606    (((dest :s16))
607     ((src :address)
608      (index :s32)))
609  (ldrsh dest (:@ src index)))
610
611(define-arm-vinsn (mem-ref-c-u8 :predicatable)
612    (((dest :u8))
613     ((src :address)
614      (index :s16const)))
615  (ldrb dest (:@ src (:$ index))))
616
617(define-arm-vinsn (mem-ref-u8 :predicatable)
618    (((dest :u8))
619     ((src :address)
620      (index :s32)))
621  (ldrb dest (:@ src index)))
622
623(define-arm-vinsn (mem-ref-c-s8 :predicatable)
624    (((dest :s8))
625     ((src :address)
626      (index :s16const)))
627  (ldrsb dest (:@ src (:$ index))))
628
629(define-arm-vinsn (mem-ref-s8 :predicatable)
630    (((dest :s8))
631     ((src :address)
632      (index :s32)))
633  (ldrsb dest (:@ src index)))
634
635(define-arm-vinsn (mem-ref-c-bit :predicatable)
636    (((dest :u8))
637     ((src :address)
638      (byte-index :s16const)
639      (bit-shift :u8const)))
640  (ldrb dest (:@ src (:$ byte-index)))
641  (mov dest (:lsr dest (:$ bit-shift)))
642  (and dest dest (:$ 1)))
643
644
645(define-arm-vinsn (mem-ref-c-bit-fixnum :predicatable)
646    (((dest :lisp))
647     ((src :address)
648      (byte-index :s16const)
649      (bit-shift :u8const))
650     ((byteval :u8)))
651  (ldrb byteval (:@ src (:$ byte-index)))
652  (mov byteval (:lsr byteval (:$ bit-shift)))
653  (and byteval byteval (:$ 1))
654  (mov dest (:lsr byteval (:$ arm::fixnumshift))))
655
656(define-arm-vinsn (mem-ref-bit :predicatable)
657    (((dest :u8))
658     ((src :address)
659      (bit-index :lisp))
660     ((byte-index :s16)
661      (bit-shift :u8)))
662
663  (mov byte-index (:lsr bit-index (:$ arm::fixnumshift)))
664  (and bit-shift byte-index (:$ 7))
665  (ldrb byte-index (:@ src (:lsr byte-index (:$ 5))))
666  (mov dest (:lsr byte-index bit-shift))
667  (and dest dest (:$ 1)))
668
669
670(define-arm-vinsn (mem-ref-bit-fixnum :predicatable)
671    (((dest :lisp))
672     ((src :address)
673      (bit-index :lisp))
674     ((byte-index :s16)
675      (bit-shift :u8)))
676  (mov byte-index (:lsr bit-index (:$ arm::fixnumshift)))
677  (and bit-shift byte-index (:$ 7))
678  (ldrb byte-index (:@ src (:lsr byte-index (:$ 3))))
679  (mov byte-index (:lsr byte-index bit-shift))
680  (mov dest (:$ arm::fixnumone))
681  (and dest dest (:lsl byte-index (:$ arm::fixnumshift))))
682
683(define-arm-vinsn (mem-ref-c-double-float :predicatable)
684    (((dest :double-float))
685     ((src :address)
686      (index :s16const)))
687  (fldd dest (:@ src (:$ index)))
688)
689
690(define-arm-vinsn (mem-ref-double-float :predicatable)
691    (((dest :double-float)
692      (src :address))
693     ((src :address)
694      (index :lisp)))
695  (add src src (:asr index (:$ arm::fixnumshift)))
696  (fldd dest (:@ src (:$ 0))))
697
698(define-arm-vinsn (mem-set-c-double-float :predicatable)
699    (()
700     ((val :double-float)
701      (src :address)
702      (index :s16const))
703     ((addr :u32)))
704  (add addr src (:$ index))
705  (fstd src (:@ addr (:$ 0))))
706
707(define-arm-vinsn (mem-set-double-float :predicatable)
708    (()
709     ((val :double-float)
710      (src :address)
711      (index :s32))                     
712     ((addr :u32)))
713  (add addr src index)
714  (fstd src (:@ addr (:$ 0))))
715
716(define-arm-vinsn (mem-ref-c-single-float :predicatable)
717    (((dest :single-float))
718     ((src :address)
719      (index :s16const)))
720  (flds dest (:@ src (:$ index))))
721
722(define-arm-vinsn (mem-ref-single-float :predicatable)
723    (((dest :single-float)
724      (src :address))
725     ((src :address)
726      (index :lisp)))
727  (add src  src (:asr index (:$ arm::fixnumshift)))
728  (flds dest (:@ src (:$ 0))))
729
730;;; The caller should check that the index is kosher
731(define-arm-vinsn (mem-set-c-single-float :predicatable)
732    (()
733     ((val :single-float)
734      (src :address)
735      (index :s16const)))
736  (fsts val (:@ src (:$ index))))
737
738(define-arm-vinsn (mem-set-single-float :predicatable)
739    (()
740     ((val :single-float)
741      (src :address)
742      (index :s32))
743     ((temp :address)))
744  (add temp src index)
745  (fsts val (:@ temp (:$ 0))))
746
747
748(define-arm-vinsn (mem-set-c-address :predicatable)
749    (()
750     ((val :address)
751      (src :address)
752      (index :s16const)))
753  (str val (:@ src (:$ index))))
754
755(define-arm-vinsn (mem-set-address :predicatable)
756    (()
757     ((val :address)
758      (src :address)
759      (index :s32)))
760  (str val (:@ src index)))
761
762(define-arm-vinsn (mem-set-c-fullword :predicatable)
763    (()
764     ((val :u32)
765      (src :address)
766      (index :s16const)))
767  (str val (:@ src (:$ index))))
768
769(define-arm-vinsn (mem-set-fullword :predicatable)
770    (()
771     ((val :u32)
772      (src :address)
773      (index :s32)))
774  (str val (:@ src index)))
775
776(define-arm-vinsn (mem-set-c-halfword :predicatable)
777    (()
778     ((val :u16)
779      (src :address)
780      (index :s16const)))
781  (strh val (:@ src (:$ index))))
782
783(define-arm-vinsn (mem-set-halfword :predicatable)
784    (()
785     ((val :u16)
786      (src :address)
787      (index :s32)))
788  (strh val (:@ src index)))
789
790(define-arm-vinsn (mem-set-c-byte :predicatable)
791    (()
792     ((val :u16)
793      (src :address)
794      (index :s16const)))
795  (strb val (:@ src (:$ index))))
796
797(define-arm-vinsn (mem-set-byte :predicatable)
798    (()
799     ((val :u8)
800      (src :address)
801      (index :s32)))
802  (strb val (:@ src index)))
803
804(define-arm-vinsn (mem-set-c-bit-0 :predicatable)
805    (()
806     ((src :address)
807      (byte-index :s16const)
808      (mask :u8const))
809     ((val :u8)))
810  (ldrb val (:@ src (:$ byte-index)))
811  (bic val val (:$ mask))
812  (strb val (:@ src (:$ byte-index))))
813
814
815(define-arm-vinsn (mem-set-c-bit-1 :predicatable)
816    (()
817     ((src :address)
818      (byte-index :s16const)
819      (mask :u8const))
820     ((val :u8)))
821  (ldrb val (:@ src (:$ byte-index)))
822  (orr val val (:$ mask))
823  (strb val (:@ src (:$ byte-index))))
824
825
826(define-arm-vinsn mem-set-c-bit (()
827                                 ((src :address)
828                                  (byte-index :s16const)
829                                  (bit-index :u8const)
830                                  (val :imm))
831                                 ((byteval :u8)
832                                  (mask :u8)))
833  (mov mask (:$ 1))
834  (mov mask (:lsl mask bit-index))
835  (cmp val (:$ 0))
836  (ldrb byteval (:@ src (:$ byte-index)))
837  (orrne byteval byteval mask)
838  (biceq byteval byteval mask)
839  (strb byteval (:@ src (:$ byte-index)))
840)
841
842;;; Hey, they should be happy that it even works.  Who cares how big it is or how
843;;; long it takes ...
844(define-arm-vinsn mem-set-bit (()
845                               ((src :address)
846                                (bit-index :lisp)
847                                (val :lisp))
848                               ((bit-shift :u32)
849                                (mask :u32)))
850  (cmp val (:$ (ash 1 arm::fixnumshift)))
851  (mov bit-shift (:$ 7))
852  (mov mask (:$ 1))
853  (and bit-shift bit-shift (:lsr bit-index (:$ arm::fixnumshift)))
854  (mov mask (:lsl mask bit-shift))
855  (ldrb bit-shift (:@ src (:lsr bit-index (:$ (+ 3 arm::fixnumshift)))))
856  (bls :ok)
857  (uuo-error-reg-not-xtype  val (:$ arm::xtype-bit))
858  :ok
859  (orrne bit-shift bit-shift mask)
860  (biceq bit-shift bit-shift mask)
861  (strb bit-shift (:@ src (:lsr bit-index (:$ (+ 3 arm::fixnumshift))))))
862     
863;;; Tag and subtag extraction, comparison, checking, trapping ...
864
865(define-arm-vinsn (extract-tag :predicatable)
866    (((tag :u8)) 
867     ((object :lisp)) 
868     ())
869  (and tag object (:$ arm::tagmask)))
870
871(define-arm-vinsn (extract-tag-fixnum :predicatable)
872    (((tag :imm))
873     ((object :lisp)))
874  (mov tag (:lsl object (:$ arm::fixnumshift)))
875  (and tag tag (:$ (ash arm::tagmask arm::fixnumshift))))
876
877(define-arm-vinsn (extract-fulltag :predicatable)
878    (((tag :u8))
879     ((object :lisp))
880     ())
881  (and tag object (:$ arm::fulltagmask)))
882
883
884(define-arm-vinsn (extract-fulltag-fixnum :predicatable)
885    (((tag :imm))
886     ((object :lisp)))
887  (mov tag (:lsl object (:$ arm::fixnumshift)))
888  (and tag tag (:$ (ash arm::fulltagmask arm::fixnumshift))))
889
890(define-arm-vinsn extract-typecode (((code :u8))
891                                    ((object :lisp))
892                                    ())
893  (and code object (:$ arm::tagmask))
894  (cmp code (:$ arm::tag-misc))
895  (ldrbeq code (:@ object (:$ arm::misc-subtag-offset))))
896
897(define-arm-vinsn extract-typecode-fixnum (((code :imm))
898                                           ((object (:lisp (:ne code))))
899                                           ((subtag :u8)))
900  (and subtag object (:$ arm::tagmask))
901  (cmp subtag (:$ arm::tag-misc))
902  (ldrbeq subtag (:@ object (:$ arm::misc-subtag-offset)))
903  (mov code (:lsl subtag (:$ arm::fixnumshift))))
904
905
906;;; Can we assume that an error handler can retry this without our
907;;; emitting a branch ?  I'd like to think so.
908(define-arm-vinsn require-fixnum (()
909                                  ((object :lisp))
910                                  ())
911  (tst object (:$ arm::tagmask))
912  (beq :ok)
913  (uuo-cerror-reg-not-lisptag object (:$ arm::tag-fixnum))
914  :ok)
915
916(define-arm-vinsn require-integer (()
917                                   ((object :lisp))
918                                   ((tag :u8)))
919  (ands tag object (:$ arm::tagmask))
920  (beq :got-it)
921  (cmp tag (:$ arm::tag-misc))
922  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
923  (cmp tag (:$ arm::subtag-bignum))
924  (beq :got-it)
925  (uuo-cerror-reg-not-xtype object (:$ arm::xtype-integer))
926  :got-it)
927
928(define-arm-vinsn require-simple-vector (()
929                                         ((object :lisp))
930                                         ((tag :u8)))
931  (and tag object (:$ arm::tagmask))
932  (cmp tag (:$ arm::tag-misc))
933  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
934  (cmp tag (:$ arm::subtag-simple-vector))
935  (beq :ok)
936  (uuo-cerror-reg-not-xtype object (:$ arm::subtag-simple-vector))
937  :ok)
938
939(define-arm-vinsn require-simple-string (()
940                                         ((object :lisp))
941                                         ((tag :u8)))
942  (and tag object (:$ arm::tagmask))
943  (cmp tag (:$ arm::tag-misc))
944  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
945  (cmp tag (:$ arm::subtag-simple-base-string))
946  (beq :ok)
947  (uuo-cerror-reg-not-xtype object (:$ arm::subtag-simple-base-string))
948  :ok)
949
950 
951(define-arm-vinsn require-real (()
952                                ((object :lisp))
953                                ((tag :u8)
954                                 (mask :u32)
955                                 (realtags :u32)))
956  (mov mask (:$ 1))
957  (and tag object (:$ arm::tagmask))
958  (movw realtags (:$ (ldb (byte 16 0) arm::real-tags-mask)))
959  (cmp tag (:$ arm::tag-misc))
960  (movt realtags (:$ (ldb (byte 16 16) arm::real-tags-mask)))
961  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
962  (tst realtags (:lsl mask tag))
963  (bne :ok)
964  (uuo-cerror-reg-not-xtype object (:$ arm::xtype-real))
965  :ok)
966
967(define-arm-vinsn require-number (()
968                                  ((object :lisp))
969                                  ((tag :u8)
970                                   (mask :u32)
971                                   (numtags :u32)))
972  (mov mask (:$ 1))
973  (and tag object (:$ arm::tagmask))
974  (movw numtags (:$ (ldb (byte 16 0) arm::numeric-tags-mask)))
975  (cmp tag (:$ arm::tag-misc))
976  (movt numtags (:$ (ldb (byte 16 16) arm::numeric-tags-mask)))
977  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
978  (tst numtags (:lsl mask tag))
979  (bne :ok)
980  (uuo-cerror-reg-not-xtype object (:$ arm::xtype-number))
981  :ok)
982
983
984(define-arm-vinsn require-list (()
985                                ((object :lisp))
986                                ((tag :u8)))
987  (and tag object (:$ arm::tagmask))
988  (cmp tag (:$ arm::tag-list))
989  (beq :ok)
990  (uuo-cerror-reg-not-lisptag object (:$ arm::tag-list))
991  :ok)
992
993(define-arm-vinsn require-symbol (()
994                                  ((object :lisp))
995                                  ((tag :u8)))
996  (and tag object (:$ arm::tagmask))
997  (cmp tag (:$ arm::tag-misc))
998  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
999  (cmpeq tag (:$ arm::subtag-symbol))
1000  (cmpne object (:$ arm::nil-value))
1001  (beq :ok)
1002  (uuo-cerror-reg-not-xtype object (:$ arm::subtag-symbol))
1003  :ok)
1004
1005(define-arm-vinsn require-character (()
1006                                     ((object :lisp))
1007                                     ((tag :u8)))
1008  (and tag object (:$ arm::subtag-mask))
1009  (cmp tag (:$ arm::subtag-character))
1010  (beq :ok)
1011  (uuo-cerror-reg-not-xtype object (:$ arm::subtag-character))
1012  :ok)
1013
1014
1015(define-arm-vinsn require-s8 (()
1016                              ((object :lisp))
1017                              ((tag :u32)))
1018  (mov tag (:lsl object (:$ (- arm::nbits-in-word (+ 8 arm::fixnumshift)))))
1019  (mov tag (:asr tag (:$ (- arm::nbits-in-word (+ 8 arm::fixnumshift)))))
1020  (cmp object (:lsl tag (:$ arm::fixnumshift)))
1021  (beq :ok)
1022  (uuo-cerror-reg-not-xtype object (:$ arm::xtype-s8))
1023  :ok)
1024
1025
1026(define-arm-vinsn require-u8 (()
1027                              ((object :lisp))
1028                              ((temp :u32)))
1029  (mov temp (:$ (lognot (ash #xff arm::fixnumshift))))
1030  (tst object temp)
1031  (beq :ok)
1032  (uuo-cerror-reg-not-xtype object (:$ arm::xtype-u8))
1033  :ok)
1034
1035(define-arm-vinsn require-s16 (()
1036                               ((object :lisp))
1037                               ( (tag :u32)))
1038  (mov tag (:lsl object (:$ (- arm::nbits-in-word (+ 16 arm::fixnumshift)))))
1039  (mov tag (:asr tag (:$ (- arm::nbits-in-word 16))))
1040  (cmp object (:lsl tag (:$ arm::fixnumshift)))
1041  (beq :ok)
1042  (uuo-cerror-reg-not-xtype object (:$ arm::xtype-s16))
1043  :ok)
1044
1045(define-arm-vinsn require-u16 (()
1046                               ((object :lisp))
1047                               ((tag :u32)))
1048  (mov tag (:$ (lognot (ash #xff arm::fixnumshift))))
1049  (bic tag tag (:$ (ash #xff (+ 8 arm::fixnumshift))))
1050  (tst object tag)
1051  (beq :ok)
1052  (uuo-cerror-reg-not-xtype object (:$ arm::xtype-u16))
1053  :ok)
1054
1055(define-arm-vinsn require-s32 (()
1056                               ((src :lisp))
1057                               ((tag :u32)
1058                                (header :u32)))
1059  (ands tag src (:$ arm::tagmask))
1060  (beq :got-it)
1061  (cmp tag (:$ arm::tag-misc))
1062  (movw tag (:$ arm::one-digit-bignum-header))
1063  (ldreq header (:@ src (:$ arm::misc-header-offset)))
1064  (cmpeq tag header)
1065  (beq :got-it)
1066  (uuo-cerror-reg-not-xtype src (:$ arm::xtype-s32))
1067  :got-it)
1068
1069
1070(define-arm-vinsn require-u32 (()
1071                               ((src :lisp))
1072                               ((temp :u32)))
1073  :again
1074  (tst src (:$ (logior (ash 1 (1- arm::nbits-in-word)) arm::tagmask)))
1075  (beq :got-it)
1076  (and temp src (:$ arm::tagmask))
1077  (cmp temp (:$ arm::tag-misc))
1078  (ldrbeq temp (:@ src (:$ arm::misc-subtag-offset)))
1079  (cmp temp (:$ arm::subtag-bignum))
1080  (bne :bad-if-ne)
1081  (ldr temp (:@ src (:$ arm::misc-header-offset)))
1082  (mov temp (:lsr temp (:$ arm::num-subtag-bits)))
1083  (cmp temp (:$ 2))
1084  (beq :two)
1085  (cmp temp (:$ 1))
1086  (bne :bad-if-ne)
1087  (ldr temp (:@ src (:$ arm::misc-data-offset)))
1088  (tst temp (:$ (ash 1 31)))
1089  (b :bad-if-ne)
1090  :two
1091  (ldr temp (:@ src (:$ (+ 4 arm::misc-data-offset))))
1092  (cmp temp (:$ 0))
1093  :bad-if-ne
1094  (beq :got-it)
1095  (uuo-cerror-reg-not-xtype src (:$ arm::xtype-u32))
1096  :got-it)
1097
1098(define-arm-vinsn require-s64 (()
1099                               ((src :lisp))
1100                               ((tag :u32)
1101                                (header :u32)))
1102  (ands tag src (:$ arm::tag-mask))
1103  (beq :got-it)
1104  (cmp tag (:$ arm::tag-misc))
1105  (ldreq header (:@ src (:$ arm::misc-header-offset)))
1106  (andeq tag header (:$ arm::subtag-mask))
1107  (cmp tag (:$ arm::subtag-bignum))
1108  (mov header (:lsr header (:$ arm::num-subtag-bits)))
1109  (bne :bad-if-ne)
1110  (cmp header (:$ 1))
1111  (beq :got-it)
1112  (cmp header (:$ 2))
1113  :bad-if-ne
1114  (beq :got-it)
1115  (uuo-cerror-reg-not-xtype src (:$ arm::xtype-s64))
1116  :got-it)
1117
1118(define-arm-vinsn require-u64 (()
1119                               ((src :lisp))
1120                               ((temp :u32)
1121                                (header :u32)))
1122  :again
1123  (tst src (:$ (logior (ash 1 31) arm::fixnum-mask)))
1124  (and temp src (:$ arm::fixnum-mask))
1125  (beq :got-it)
1126  (cmp temp (:$ arm::tag-misc))
1127  (ldreq header (:@ src (:$ arm::misc-header-offset)))
1128  (andeq temp src (:$ arm::subtag-mask))
1129  (moveq header (:lsr header (:$ arm::num-subtag-bits)))
1130  (cmpeq temp (:$ arm::subtag-bignum))
1131  (bne :bad-if-ne)
1132  (cmp header (:$ 3))
1133  (ldreq temp (:@ src (:$ (+ arm::misc-data-offset 8))))
1134  (beq :three)
1135  (cmp header (:$ 2))
1136  (ldreq temp (:@ src (:$ (+ arm::misc-data-offset 4))))
1137  (beq :sign-of-highword)
1138  (cmp header (:$ 1))
1139  (ldr temp (:@ src (:$ arm::misc-data-offset)))
1140  (bne :bad-if-ne)
1141  :sign-of-highword
1142  (tst temp (:$ (ash 1 31)))
1143  (b :bad-if-ne)
1144  :three
1145  (cmp temp (:$ 0))
1146  :bad-if-ne
1147  (beq :got-it)
1148  (uuo-cerror-reg-not-xtype src (:$ arm::xtype-s64))
1149  :got-it)
1150
1151
1152
1153
1154(define-arm-vinsn require-char-code (()
1155                                     ((object :lisp)))
1156  (tst object (:$ arm::fixnum-mask))
1157  (bne :bad)
1158  (cmp object (:$ (ash char-code-limit arm::fixnumshift)))
1159  (bls :got-it)
1160  :bad
1161  (uuo-error-reg-not-xtype object (:$ arm::xtype-char-code))
1162  :got-it)
1163
1164
1165(define-arm-vinsn (box-fixnum :predicatable)
1166    (((dest :imm))
1167     ((src :s32)))
1168  (mov dest (:lsl src (:$ arm::fixnumshift))))
1169
1170(define-arm-vinsn (fixnum->signed-natural :predicatable)
1171    (((dest :s32))
1172     ((src :imm)))
1173  (mov dest (:asr src (:$ arm::fixnumshift))))
1174
1175(define-arm-vinsn (fixnum->unsigned-natural :predicatable)
1176    (((dest :u32))
1177     ((src :imm)))
1178  (mov dest (:lsr src (:$ arm::fixnumshift))))
1179
1180;;; An object is of type (UNSIGNED-BYTE 32) iff
1181;;;  a) it's of type (UNSIGNED-BYTE 30) (e.g., an unsigned fixnum)
1182;;;  b) it's a bignum of length 1 and the 0'th digit is positive
1183;;;  c) it's a bignum of length 2 and the sign-digit is 0.
1184
1185(define-arm-vinsn unbox-u32 (((dest :u32))
1186                             ((src :lisp))
1187                             ((temp :u32)))
1188                             
1189  (tst src (:$ #x80000003))
1190  (mov dest (:lsr src (:$ arm::fixnumshift)))
1191  (beq :got-it)
1192  (and temp src (:$ arm::tagmask))
1193  (cmp temp (:$ arm::tag-misc))
1194  (beq :is-uvector)
1195  (uuo-error-reg-not-xtype src (:$ arm::xtype-u32))
1196  :is-uvector
1197  (ldr dest (:@ src (:$ arm::misc-header-offset)))
1198  (movw temp (:$ arm::one-digit-bignum-header))
1199  (cmp dest temp)
1200  (bne :maybe-two-digit)
1201  (ldr dest (:@ src (:$ arm::misc-data-offset)))
1202  (tst dest (:$ (ash 1 31)))
1203  (beq :got-it)
1204  (uuo-error-reg-not-xtype src (:$ arm::xtype-u32))
1205  :maybe-two-digit
1206  (add temp temp (:$ (ash 1 arm::num-subtag-bits)))
1207  (cmp dest temp)
1208  (ldreq temp (:@ src (:$ (+ arm::misc-data-offset 4))))
1209  (cmpeq temp (:$ 0))
1210  (ldreq dest (:@ src (:$ arm::misc-data-offset)))
1211  (beq :got-it)
1212  (uuo-error-reg-not-xtype src (:$ arm::xtype-u32))
1213  :got-it)
1214
1215;;; an object is of type (SIGNED-BYTE 32) iff
1216;;; a) it's a fixnum
1217;;; b) it's a bignum with exactly one digit.
1218
1219(define-arm-vinsn unbox-s32 (((dest :s32))
1220                             ((src :lisp))
1221                             ((tag :u32)))
1222  (ands tag src (:$ arm::tagmask))
1223  (mov dest (:asr src (:$ arm::fixnumshift)))
1224  (beq :got-it)
1225  (movw dest (:$ arm::one-digit-bignum-header))
1226  (cmp tag (:$ arm::tag-misc))
1227  (ldreq tag (:@ src (:$ arm::misc-header-offset)))
1228  (cmpeq dest tag)
1229  (ldreq dest (:@ src (:$ arm::misc-data-offset)))
1230  (beq :got-it)
1231  (uuo-error-reg-not-xtype src (:$ arm::xtype-s32))
1232  :got-it)
1233
1234
1235
1236(define-arm-vinsn unbox-u16 (((dest :u16))
1237                             ((src :lisp)))
1238  (mov dest (:lsl src (:$ (- 16 arm::fixnumshift))))
1239  (mov dest (:lsr dest (:$ 16)))
1240  (cmp src (:lsl dest (:$ arm::fixnumshift)))
1241  (beq :ok)
1242  (uuo-error-reg-not-xtype src (:$ arm::xtype-u16))
1243  :ok)
1244
1245(define-arm-vinsn unbox-s16 (((dest :s16))
1246                             ((src :lisp)))
1247  (mov dest (:lsl src (:$ (- arm::nbits-in-word (+ 16 arm::fixnumshift)))))
1248  (mov dest (:asr dest (:$ 16)))
1249  (cmp src (:lsl dest (:$ arm::fixnumshift)))
1250  (beq :ok)
1251  (uuo-error-reg-not-xtype src (:$ arm::xtype-s16))
1252  :ok)
1253
1254 
1255 
1256(define-arm-vinsn unbox-u8 (((dest :u8))
1257                            ((src :lisp)))
1258  (mov dest (:lsl src (:$ (- 24 arm::fixnumshift))))
1259  (mov dest (:lsr dest (:$ 24)))
1260  (cmp src (:lsl dest (:$ arm::fixnumshift)))
1261  (beq :ok)
1262  (uuo-error-reg-not-xtype src (:$ arm::xtype-u8))
1263  :ok)
1264
1265(define-arm-vinsn (%unbox-u8 :predicatable)
1266    (((dest :u8))
1267     ((src :lisp)))
1268  (mov dest (:$ #xff))
1269  (and dest dest (:lsr src (:$ arm::fixnumshift))))
1270
1271(define-arm-vinsn unbox-s8 (((dest :s8))
1272                            ((src :lisp)))
1273  (mov dest (:lsl src (:$ (- 24 arm::fixnumshift))))
1274  (mov dest (:asr dest (:$ 24)))
1275  (cmp src (:lsl dest (:$ arm::fixnumshift)))
1276  (beq :ok)
1277  (uuo-error-reg-not-xtype src (:$ arm::xtype-s8))
1278  :ok)
1279
1280(define-arm-vinsn unbox-base-char (((dest :u32))
1281                                   ((src :lisp)))
1282  (and dest src (:$ arm::subtag-mask))
1283  (cmp dest (:$ arm::subtag-character))
1284  (mov dest (:lsr src (:$ arm::charcode-shift)))
1285  (beq :ok)
1286  (uuo-error-reg-not-xtype src (:$ arm::subtag-character))
1287  :ok)
1288
1289
1290(define-arm-vinsn unbox-bit (((dest :u32))
1291                             ((src :lisp)))
1292  (cmp src (:$ arm::fixnumone))
1293  (mov dest (:lsr src (:$ arm::fixnumshift)))
1294  (bls :ok)
1295  (uuo-error-reg-not-xtype src (:$ arm::xtype-bit))
1296  :ok)
1297
1298
1299
1300(define-arm-vinsn (fixnum->double :predicatable)
1301    (((dest :double-float))
1302     ((src :lisp)
1303      (temp :single-float))
1304     ((imm :s32)))
1305  (mov imm (:asr src (:$ arm::fixnumshift)))
1306  (fmsr temp imm)
1307  (fsitod dest temp))
1308
1309
1310(define-arm-vinsn (fixnum->single :predicatable)
1311    (((dest :single-float))
1312     ((src :lisp))
1313     ((imm :s32)))
1314  (mov imm (:asr src (:$ arm::fixnumshift)))
1315  (fmsr dest imm)
1316  (fsitos dest dest))
1317
1318(define-arm-vinsn (fixnum->single-safe :call :subprim-call)
1319    (((dest :single-float))
1320     ((src :lisp))
1321     ((imm :s32)))
1322  (fmrx imm :fpscr)
1323  (bic imm imm (:$ #xff))
1324  (fmxr :fpscr imm)
1325  (mov imm (:asr src (:$ arm::fixnumshift)))
1326  (fmsr dest imm)
1327  (fsitos dest dest)
1328  (sploadlr .SPcheck-fpu-exception)
1329  (blx lr))
1330
1331(define-arm-vinsn (shift-left-variable-word :predicatable)
1332    (((dest :u32))
1333     ((src :u32)
1334      (sh :u32)))
1335  (mov dest (:lsl src sh)))
1336
1337(define-arm-vinsn (u32logandc2 :predicatable)
1338    (((dest :u32))
1339     ((x :u32)
1340      (y :u32)))
1341  (bic dest x y))
1342
1343(define-arm-vinsn (u32logior :predicatable)
1344    (((dest :u32))
1345     ((x :u32)
1346      (y :u32)))
1347  (orr dest x y))
1348
1349(define-arm-vinsn set-or-clear-bit (((dest :u32))
1350                                    ((src :u32)
1351                                     (mask :u32)
1352                                     (crf :crf)))
1353  (biceq dest src mask)
1354  (orrne dest src mask))
1355
1356(define-arm-vinsn (complement-shift-count :predicatable)
1357    (((dest :u32))
1358     ((src :u32)))
1359  (rsb dest src (:$ 32)))
1360
1361(define-arm-vinsn (extract-lowbyte :predicatable)
1362    (((dest :u32))
1363     ((src :lisp)))
1364  (and dest src (:$ arm::subtag-mask)))
1365
1366
1367
1368
1369(define-arm-vinsn trap-unless-fixnum (()
1370                                      ((object :lisp)))
1371  (tst object (:$ arm::fixnummask))
1372  (beq :ok)
1373  (uuo-error-reg-not-lisptag object (:$ arm::tag-fixnum))
1374  :ok)
1375
1376(define-arm-vinsn trap-unless-list (()
1377                                    ((object :lisp))
1378                                    ((tag :u8)))
1379  (and tag object (:$ arm::tagmask))
1380  (cmp tag (:$ arm::tag-list))
1381  (beq :ok)
1382  (uuo-error-reg-not-lisptag object (:$ arm::tag-list))
1383  :ok)
1384
1385(define-arm-vinsn trap-unless-single-float (()
1386                                            ((object :lisp))
1387                                            ((tag :u8)))
1388  (and tag object (:$ arm::tagmask))
1389  (cmp tag (:$ arm::tag-misc))
1390  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
1391  (cmp tag (:$ arm::subtag-single-float))
1392  (beq :ok)
1393  (uuo-error-reg-not-xtype object (:$ arm::subtag-single-float))
1394  :ok)
1395
1396(define-arm-vinsn trap-unless-double-float (()
1397                                            ((object :lisp))
1398                                            ((tag :u8)))
1399  (and tag object (:$ arm::tagmask))
1400  (cmp tag (:$ arm::tag-misc))
1401  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
1402  (cmp tag (:$ arm::subtag-double-float))
1403  (beq :ok)
1404  (uuo-error-reg-not-xtype object (:$ arm::subtag-double-float))
1405  :ok)
1406
1407
1408(define-arm-vinsn trap-unless-array-header (()
1409                                            ((object :lisp))
1410                                            ((tag :u8)))
1411  (and tag object (:$ arm::tagmask))
1412  (cmp tag (:$ arm::tag-misc))
1413  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
1414  (cmp tag (:$ arm::subtag-arrayH))
1415  (beq :ok)
1416  (uuo-error-reg-not-xtype object (:$ arm::subtag-arrayH))
1417  :ok)
1418
1419(define-arm-vinsn trap-unless-macptr (()
1420                                      ((object :lisp))
1421                                      ((tag :u8)))
1422  (and tag object (:$ arm::tagmask))
1423  (cmp tag (:$ arm::tag-misc))
1424  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
1425  (cmp tag (:$ arm::subtag-macptr))
1426  (beq :ok)
1427  (uuo-error-reg-not-xtype object (:$ arm::subtag-macptr))
1428  :ok)
1429
1430
1431
1432(define-arm-vinsn trap-unless-uvector (()
1433                                       ((object :lisp))
1434                                       ((tag :u8)))
1435  (and tag object (:$ arm::tagmask))
1436  (cmp tag (:$ arm::tag-misc))
1437  (beq :ok)
1438  (uuo-error-reg-not-lisptag object (:$ arm::tag-misc))
1439  :ok)
1440
1441
1442
1443(define-arm-vinsn trap-unless-character (()
1444                                         ((object :lisp))
1445                                         ((tag :u8)))
1446  (and tag object (:$ arm::subtag-mask))
1447  (cmp tag (:$ arm::subtag-character))
1448  (beq :ok)
1449  (uuo-error-reg-not-xtype object (:$ arm::subtag-character))
1450  :ok)
1451
1452(define-arm-vinsn trap-unless-cons (()
1453                                    ((object :lisp))
1454                                    ((tag :u8)))
1455  (and tag object (:$ arm::fulltagmask))
1456  (cmp tag (:$ arm::fulltag-cons))
1457  (beq :ok)
1458  (uuo-error-reg-not-fulltag  object (:$ arm::fulltag-cons))
1459  :ok)
1460
1461(define-arm-vinsn trap-unless-typecode= (()
1462                                         ((object :lisp)
1463                                          (tagval :u16const))
1464                                         ((tag :u8)))
1465  (and tag object (:$ arm::tagmask))
1466  (cmp tag (:$ arm::tag-misc))
1467  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
1468  (cmp tag (:$ tagval))
1469  (beq :ok)
1470  (uuo-error-reg-not-xtype object (:$ tagval))
1471  :ok)
1472 
1473(define-arm-vinsn (subtract-constant :predicatable)
1474    (((dest :imm))
1475     ((src :imm)
1476      (const :s16const)))
1477  (sub dest src (:$ const)))
1478
1479
1480
1481;; Bit-extraction & boolean operations
1482
1483
1484;; For some mind-numbing reason, IBM decided to call the most significant
1485;; bit in a 32-bit word "bit 0" and the least significant bit "bit 31"
1486;; (this despite the fact that it's essentially a big-endian architecture
1487;; (it was exclusively big-endian when this decision was made.))
1488;; We'll probably be least confused if we consistently use this backwards
1489;; bit ordering (letting things that have a "sane" bit-number worry about
1490;; it at compile-time or run-time (subtracting the "sane" bit number from
1491;; 31.))
1492
1493#+later
1494(define-arm-vinsn extract-variable-bit (((dest :u8))
1495                                        ((src :u32)
1496                                         (bitnum :u8))
1497                                        ())
1498  (rotlw dest src bitnum)
1499  (extrwi dest dest 1 0))
1500
1501
1502(define-arm-vinsn (extract-variable-bit-fixnum :predicatable)
1503    (((dest :lisp))
1504     ((src :u32)
1505      (bitnum :u8))
1506     ((temp :u32)))
1507  (mov temp (:lsr src bitnum))
1508  (mov dest (:$ arm::fixnumone))
1509  (and dest dest (:lsl temp (:$ arm::fixnumshift))))
1510
1511
1512
1513                           
1514
1515
1516
1517(define-arm-vinsn compare (((crf :crf))
1518                           ((arg0 t)
1519                            (arg1 t))
1520                           ())
1521  (cmp arg0 arg1))
1522
1523(define-arm-vinsn compare-to-nil (((crf :crf))
1524                                  ((arg0 t)))
1525  (cmp arg0 (:$ arm::nil-value)))
1526
1527(define-arm-vinsn compare-logical (((crf :crf))
1528                                   ((arg0 t)
1529                                    (arg1 t))
1530                                   ())
1531  (cmp  arg0 arg1))
1532
1533(define-arm-vinsn compare-immediate (((crf :crf))
1534                                     ((arg t)
1535                                      (imm :u32const)))
1536  (cmp arg (:$ imm)))
1537
1538(define-arm-vinsn double-float-compare (((crf :crf))
1539                                        ((arg0 :double-float)
1540                                         (arg1 :double-float))
1541                                        ())
1542  (fcmped arg0 arg1)
1543  (fmstat))
1544             
1545
1546(define-arm-vinsn (double-float+-2 :predicatable)
1547    (((result :double-float))
1548     ((x :double-float)
1549      (y :double-float)))
1550  (faddd result x y))
1551
1552(define-arm-vinsn (double-float+-2-safe :call :subprim-call)
1553    (((result :double-float))
1554     ((x :double-float)
1555      (y :double-float))
1556     ((imm :u32)))
1557  (fmrx imm :fpscr)
1558  (bic imm imm (:$ #xff))
1559  (fmxr :fpscr imm)
1560  (faddd result x y)
1561  (sploadlr .SPcheck-fpu-exception)
1562  (blx lr))
1563
1564(define-arm-vinsn (double-float--2 :predicatable)
1565    (((result :double-float))
1566     ((x :double-float)
1567      (y :double-float)))
1568  (fsubd result x y))
1569
1570(define-arm-vinsn (double-float-2-safe :call :subprim-call)
1571    (((result :double-float))
1572     ((x :double-float)
1573      (y :double-float))
1574     ((imm :u32)))
1575  (fmrx imm :fpscr)
1576  (bic imm imm (:$ #xff))
1577  (fmxr :fpscr imm)
1578  (fsubd result x y)
1579  (sploadlr .SPcheck-fpu-exception)
1580  (blx lr))
1581
1582(define-arm-vinsn (double-float*-2 :predicatable)
1583    (((result :double-float))
1584     ((x :double-float)
1585      (y :double-float)))
1586  (fmuld result x y))
1587
1588(define-arm-vinsn (double-float*-2-safe :call :subprim-call)
1589    (((result :double-float))
1590     ((x :double-float)
1591      (y :double-float))
1592     ((imm :u32)))
1593  (fmrx imm :fpscr)
1594  (bic imm imm (:$ #xff))
1595  (fmxr :fpscr imm)
1596  (fmuld result x y)
1597  (sploadlr .SPcheck-fpu-exception)
1598  (blx lr))
1599
1600(define-arm-vinsn (double-float/-2 :predicatable)
1601    (((result :double-float))
1602     ((x :double-float)
1603      (y :double-float)))
1604  (fdivd result x y))
1605
1606(define-arm-vinsn (double-float/-2-safe :call :subprim-call)
1607    (((result :double-float))
1608     ((x :double-float)
1609      (y :double-float))
1610     ((imm :u32)))
1611  (fmrx imm :fpscr)
1612  (bic imm imm (:$ #xff))
1613  (fmxr :fpscr imm)
1614  (fdivd result x y)
1615  (sploadlr .SPcheck-fpu-exception)
1616  (blx lr))
1617
1618(define-arm-vinsn (double-float-negate :predicatable) (((dest :double-float))
1619                                                       ((src :double-float)))
1620  (fnegd dest src))
1621
1622
1623
1624(define-arm-vinsn single-float-compare (((crf :crf))
1625                                        ((arg0 :single-float)
1626                                         (arg1 :single-float))
1627                                        ())
1628  (fcmpes arg0 arg1)
1629  (fmstat))
1630
1631(define-arm-vinsn (single-float+-2 :predicatable)
1632    (((result :single-float))
1633     ((x :single-float)
1634      (y :single-float))
1635     ())
1636  (fadds result x y))
1637
1638(define-arm-vinsn (single-float+-2-safe :call :subprim-call)
1639    (((result :single-float))
1640     ((x :single-float)
1641      (y :single-float))
1642     ((imm :u32)))
1643  (fmrx imm :fpscr)
1644  (bic imm imm (:$ #xff))
1645  (fmxr :fpscr imm)
1646  (fadds result x y)
1647  (sploadlr .SPcheck-fpu-exception)
1648  (blx lr))
1649
1650(define-arm-vinsn (single-float--2 :predicatable)
1651    (((result :single-float))
1652     ((x :single-float)
1653      (y :single-float)))
1654  (fsubs result x y))
1655
1656(define-arm-vinsn (single-float--2-safe :call :subprim-call)
1657    (((result :single-float))
1658     ((x :single-float)
1659      (y :single-float))
1660     ((imm :u32)))
1661  (fmrx imm :fpscr)
1662  (bic imm imm (:$ #xff))
1663  (fmxr :fpscr imm)
1664  (fsubs result x y)
1665  (sploadlr .SPcheck-fpu-exception)
1666  (blx lr))
1667
1668(define-arm-vinsn (single-float*-2 :predicatable)
1669    (((result :single-float))
1670     ((x :single-float)
1671      (y :single-float)))
1672  (fmuls result x y))
1673
1674(define-arm-vinsn (single-float*-2-safe :call :subprim-call)
1675    (((result :single-float))
1676     ((x :single-float)
1677      (y :single-float))
1678     ((imm :u32)))
1679  (fmrx imm :fpscr)
1680  (bic imm imm (:$ #xff))
1681  (fmxr :fpscr imm)
1682  (fmuls result x y)
1683  (sploadlr .SPcheck-fpu-exception)
1684  (blx lr))
1685
1686(define-arm-vinsn (single-float/-2 :predicatable)
1687    (((result :single-float))
1688     ((x :single-float)
1689      (y :single-float)))
1690  (fdivs result x y))
1691
1692(define-arm-vinsn (single-float/-2-safe :call :subprim-call)
1693    (((result :single-float))
1694     ((x :single-float)
1695      (y :single-float))
1696     ((imm :u32)))
1697  (fmrx imm :fpscr)
1698  (bic imm imm (:$ #xff))
1699  (fmxr :fpscr imm)
1700  (fdivs result x y)
1701  (sploadlr .SPcheck-fpu-exception)
1702  (blx lr))
1703
1704(define-arm-vinsn (single-float-negate :predicatable) (((dest :single-float))
1705                                                       ((src :single-float)))
1706  (fnegs dest src))
1707
1708
1709(define-arm-vinsn compare-unsigned (()
1710                                    ((arg0 :imm)
1711                                     (arg1 :imm))
1712                                    ())
1713  (cmp arg0 arg1))
1714
1715
1716
1717
1718
1719;; Extract a constant bit (0-31) from src; make it be bit 31 of dest.
1720;; Bitnum is treated mod 32.
1721#+later
1722(define-arm-vinsn extract-constant-arm-bit (((dest :u32))
1723                                            ((src :imm)
1724                                             (bitnum :u16const))
1725                                            ())
1726  (rlwinm dest src (:apply + 1 bitnum) 31 31))
1727
1728
1729
1730(define-arm-vinsn set-constant-arm-bit-to-variable-value (((dest :u32))
1731                                                          ((src :u32)
1732                                                           (bitval :u32) ; 0 or 1
1733                                                           (bitnum :u8const)))
1734  (cmp bitval (:$ 0))
1735  (biceq dest src (:$ (:apply ash 1 bitnum)))
1736  (orrne dest src (:$ (:apply ash 1 bitnum))))
1737
1738(define-arm-vinsn (set-constant-arm-bit-to-1 :predicatable)
1739    (((dest :u32))
1740     ((src :u32)
1741      (bitnum :u8const)))
1742  (orr dest src (:$ (:apply ash 1 bitnum))))
1743
1744
1745(define-arm-vinsn (set-constant-arm-bit-to-0 :predicatable)
1746    (((dest :u32))
1747     ((src :u32)
1748      (bitnum :u8const)))
1749  (bic dest src (:$ (:apply ash 1 bitnum))))
1750
1751
1752
1753                                               
1754;;; Operations on lists and cons cells
1755
1756(define-arm-vinsn (%cdr :predicatable)
1757    (((dest :lisp))
1758     ((src :lisp)))
1759  (ldr dest (:@ src (:$ arm::cons.cdr))))
1760
1761(define-arm-vinsn (%car :predicatable)
1762    (((dest :lisp))
1763     ((src :lisp)))
1764  (ldr dest (:@ src (:$ arm::cons.car))))
1765
1766(define-arm-vinsn (%set-car :predicatable)
1767    (()
1768     ((cell :lisp)
1769      (new :lisp)))
1770  (str cell (:@ new (:$ arm::cons.car))))
1771
1772(define-arm-vinsn (%set-cdr :predicatable)
1773    (()
1774     ((cell :lisp)
1775      (new :lisp)))
1776  (str cell (:@ new (:$ arm::cons.cdr))))
1777
1778
1779(define-arm-vinsn (load-adl :predicatable)
1780    (()
1781     ((n :u32const)))
1782  (mov nargs (:$ (:apply logand #x00ff0000 n)))
1783  ((:not (:pred = 0 (:apply logand #xff000000 n)))
1784   (orr nargs nargs (:$ (:apply logand #xff000000 n))))
1785  ((:not (:pred = 0 (:apply logand #x0000ff00 n)))
1786   (orr nargs nargs (:$ (:apply logand #x0000ff00 n))))
1787  ((:not (:pred = 0 (:apply logand #x000000ff n)))
1788   (orr nargs nargs (:$ (:apply logand #x000000ff n)))))
1789                           
1790(define-arm-vinsn (set-nargs :predicatable)
1791    (()
1792     ((n :s16const)))
1793  ((:pred < n 256)
1794   (mov nargs (:$ (:apply ash n arm::word-shift))))
1795  ((:pred >= n 256)
1796   (movw nargs (:$ (:apply ash n arm::word-shift)))))
1797
1798(define-arm-vinsn (scale-nargs :predicatable)
1799    (()
1800     ((nfixed :s16const)))
1801  ((:pred > nfixed 0)
1802   (add nargs nargs (:$ (:apply - (:apply ash nfixed arm::word-shift))))))
1803                           
1804
1805
1806(define-arm-vinsn (vpush-register :push :node :vsp :predicatable)
1807   
1808    (()
1809     ((reg :lisp)))
1810  (str reg (:@! vsp (:$ (- arm::node-size)))))
1811
1812(define-arm-vinsn (vpush-multiple-registers :push :node :multiple :vsp :predicatable)
1813    (()
1814     ((mask :u16const)))
1815  (stmdb (:! arm::vsp) (:$ mask)))
1816
1817(define-arm-vinsn (vpush-register-arg :push :node :vsp :outgoing-argument :predicatable)
1818    (()
1819     ((reg :lisp)))
1820  (str reg (:@! vsp (:$ (- arm::node-size)))))
1821
1822(define-arm-vinsn (vpush-register-arg :push :node :vsp :outgoing-argument :predicatable)
1823    (()
1824     ((reg :lisp)))
1825  (str reg (:@! vsp (:$ (- arm::node-size)))))
1826
1827(define-arm-vinsn (vpush-xyz :push :node :vsp :predicatable)
1828    (() ())
1829  (stmdb (:! vsp) (arg_z arg_y arg_x)))
1830
1831(define-arm-vinsn (vpush-yz :push :node :vsp :predicatable)
1832    (() ())
1833  (stmdb (:! vsp) (arg_z arg_y)))
1834
1835(define-arm-vinsn (vpush-argregs :push :node :vsp) (()
1836                                                    ((num-fixed-args :u16const)))
1837  ((:pred = num-fixed-args 0)
1838   (cmp nargs (:$ 0))
1839   (beq :done))
1840  ((:pred < num-fixed-args 2)
1841   (cmp nargs (:$ (ash 2 arm::fixnumshift)))
1842   (strlo arg_z (:@! vsp (:$ (- arm::node-size))))
1843   (stmdbeq (:! vsp) (arg_z arg_y))
1844   (stmdbhi (:! vsp) (arg_z arg_y arg_x))
1845   :done)
1846  ((:pred = num-fixed-args 2)
1847   (cmp nargs (:$ (ash 2 arm::fixnumshift)))
1848   (stmdbeq (:! vsp) (arg_z arg_y))
1849   (stmdbhi (:! vsp) (arg_z arg_y arg_x)))
1850  ((:pred > num-fixed-args 2)
1851   (stmdb (:! vsp) (arg_z arg_y arg_x))))
1852
1853
1854(define-arm-vinsn (vpop-register :pop :node :vsp :predicatable)
1855   
1856    (((dest :lisp))
1857     ())
1858  (ldr dest (:@+ vsp (:$ arm::node-size))))
1859
1860(define-arm-vinsn (pop-argument-registers :pop :node :vsp) (()
1861                                                            ())
1862  (cmp nargs (:$ 0))
1863  (beq :done)
1864  (cmp nargs (:$ (* 2 arm::node-size)))
1865  (ldrlt arg_z (:@+ vsp (:$ arm::node-size)))
1866  (ldmiaeq (:! vsp) (arg_z arg_y))
1867  (ldmiagt (:! vsp) (arg_z arg_y arg_x))
1868  :done)
1869
1870
1871
1872(define-arm-vinsn (copy-node-gpr :predicatable)
1873    (((dest :lisp))
1874     ((src :lisp)))
1875  ((:not (:pred =
1876                (:apply %hard-regspec-value dest)
1877                (:apply %hard-regspec-value src)))
1878   (mov dest src)))
1879
1880(define-arm-vinsn (copy-gpr :predicatable)
1881    (((dest t))
1882     ((src t)))
1883  ((:not (:pred =
1884                (:apply %hard-regspec-value dest)
1885                (:apply %hard-regspec-value src)))
1886   (mov dest src)))
1887
1888
1889(define-arm-vinsn (double-to-double :predicatable)
1890    (((dest :double-float))
1891     ((src :double-float)))
1892  ((:not (:pred =
1893                (:apply %hard-regspec-value dest)
1894                (:apply %hard-regspec-value src)))
1895   (fcpyd dest src)))
1896
1897(define-arm-vinsn (single-to-single :predicatable)
1898    (((dest :single-float))
1899     ((src :single-float)))
1900  ((:not (:pred =
1901                (:apply %hard-regspec-value dest)
1902                (:apply %hard-regspec-value src)))
1903   (fcpys dest src)))
1904
1905(define-arm-vinsn (vcell-ref :predicatable)
1906    (((dest :lisp))
1907     ((vcell :lisp)))
1908  (ldr dest (:@ vcell (:$ arm::misc-data-offset))))
1909
1910
1911(define-arm-vinsn make-vcell (((dest :lisp))
1912                              ((closed (:lisp :ne dest)))
1913                              ((header :u32)))
1914  (movw header (:$ (logior (ash arm::value-cell.element-count arm::num-subtag-bits) arm::subtag-value-cell)))
1915  (sub allocptr allocptr (:$ (- arm::value-cell.size arm::fulltag-misc)))
1916  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
1917  (cmp allocptr dest)
1918  (bhi :no-trap)
1919  (uuo-alloc-trap)
1920  :no-trap
1921  (str header (:@ allocptr (:$ arm::misc-header-offset)))
1922  (mov dest allocptr)
1923  (bic allocptr allocptr (:$ arm::fulltagmask))
1924  (str closed (:@ dest (:$ arm::value-cell.value))))
1925
1926(define-arm-vinsn (make-stack-vcell :predicatable)
1927    (((dest :lisp))
1928     ((closed :lisp))
1929     ((header :u32)))
1930  (movw header (:$ (logior (ash arm::value-cell.element-count arm::num-subtag-bits) arm::subtag-value-cell)))
1931  (stmdb (:! sp) (closed header))
1932  (add dest sp (:$ arm::fulltag-misc)))
1933
1934(define-arm-vinsn (make-stack-cons :predicatable)
1935    (((dest :lisp))
1936     ((car :lisp) (cdr :lisp))
1937     ((header (:u32 #.arm::imm0))
1938      (zero (:u32 #.arm::imm1))))
1939  (movw header (:$ (logior (ash 3 arm::num-subtag-bits) arm::subtag-value-cell)))
1940  (mov zero (:$ 0))
1941  ((:pred <
1942          (:apply %hard-regspec-value cdr)
1943          (:apply %hard-regspec-value car))
1944   (stmdb (:! sp) (car cdr zero header)))
1945  ((:not (:pred <
1946                (:apply %hard-regspec-value cdr)
1947                (:apply %hard-regspec-value car)))
1948   (stmdb (:! sp) (cdr car zero header))
1949   (str car (:@ sp (:$ 12)))
1950   (str cdr (:@ sp (:$ 8))))
1951  (add dest sp (:$ (+ arm::dnode-size arm::fulltag-cons))))
1952
1953
1954(define-arm-vinsn (%closure-code% :predicatable)
1955    (((dest :lisp))
1956     ())
1957  (mov dest (:$ arm::nil-value))
1958  (ldr dest (:@ dest (:$ (:apply + arm::symbol.vcell (arm::nrs-offset %closure-code%))))))
1959
1960;;; DEST pretty much has to be the LR, which won't stay alive very long.
1961(define-arm-vinsn %codevector-entry (((dest t))
1962                                     ((cv :lisp)))
1963  (add dest cv (:$ arm::misc-data-offset)))
1964
1965
1966(define-arm-vinsn (single-float-bits :predicatable)
1967    (((dest :u32))
1968     ((src :lisp)))
1969  (ldr dest (:@ src (:$ arm::single-float.value))))
1970
1971(define-arm-vinsn (call-subprim :call :subprim-call) (()
1972                                                      ((spno :s32const)))
1973  (sploadlr spno)
1974  (blx lr))
1975
1976(define-arm-vinsn (jump-subprim :jumpLR) (()
1977                                          ((spno :s32const)))
1978  (spjump spno))
1979
1980;;; Same as "call-subprim", but gives us a place to
1981;;; track args, results, etc.
1982(define-arm-vinsn (call-subprim-0 :call :subprim-call) (((dest t))
1983                                                        ((spno :s32const)))
1984  (sploadlr spno)
1985  (blx lr))
1986
1987(define-arm-vinsn (call-subprim-1 :call :subprim-call) (((dest t))
1988                                                        ((spno :s32const)
1989                                                         (z t)))
1990  (sploadlr spno)
1991  (blx lr))
1992 
1993(define-arm-vinsn (call-subprim-2 :call :subprim-call) (((dest t))
1994                                                        ((spno :s32const)
1995                                                         (y t)
1996                                                         (z t)))
1997  (sploadlr spno)
1998  (blx lr))
1999
2000(define-arm-vinsn (call-subprim-3 :call :subprim-call) (((dest t))
2001                                                        ((spno :s32const)
2002                                                         (x t)
2003                                                         (y t)
2004                                                         (z t)))
2005  (sploadlr spno)
2006  (blx lr))
2007
2008
2009
2010(define-arm-vinsn (ref-interrupt-level :predicatable)
2011    (((dest :imm))
2012     ()
2013     ((temp :u32)))
2014  (ldr temp (:@ rcontext (:$ arm::tcr.tlb-pointer)))
2015  (ldr dest (:@ temp (:$ arm::INTERRUPT-LEVEL-BINDING-INDEX))))
2016
2017                         
2018;;; Unconditional (pc-relative) branch
2019(define-arm-vinsn (jump :jump :predicatable)
2020    (()
2021     ((label :label)))
2022  (b label))
2023
2024(define-arm-vinsn (call-label :call) (()
2025                                      ((label :label)))
2026  (bl label))
2027
2028;;; just like JUMP, only (implicitly) asserts that the following
2029;;; code is somehow reachable.
2030(define-arm-vinsn (non-barrier-jump :xref) (()
2031                                            ((label :label)))
2032  (b label))
2033
2034
2035(define-arm-vinsn (skip-unless-fixnum-in-range :branch)
2036    (((idx :u32))
2037     ((reg :imm)
2038      (minval :s32const)
2039      (maxval :u32const)
2040      (default :label))
2041     ((temp :s32)))
2042  (:drain-constant-pool)
2043  (tst reg (:$ arm::fixnummask))
2044  (mov idx (:asr reg (:$  arm::fixnumshift)))
2045  (bne default)
2046  ((:not (:pred zerop minval))
2047   ((:pred arm::encode-arm-immediate minval)
2048    (sub idx idx (:$ minval)))
2049   ((:not (:pred arm::encode-arm-immediate minval))
2050    ((:pred arm::encode-arm-immediate (:apply - minval))
2051     (add idx idx (:$ (:apply - minval))))
2052    ((:not (:pred arm::encode-arm-immediate (:apply - minval)))
2053     ((:and (:pred >=  minval 0)
2054            (:pred < minval #x10000))
2055      (movw temp (:$ minval)))
2056     ((:not (:and
2057             (:pred >=  minval 0)
2058             (:pred < minval #x10000)))
2059      (movw temp (:$ (:apply logand #xffff minval)))
2060      (movt temp (:$ (:apply ldb (byte 16 16) minval))))
2061     (sub idx idx temp))))
2062  ((:pred arm::encode-arm-immediate maxval)
2063   (cmp idx (:$ maxval)))
2064  ((:not (:pred arm::encode-arm-immediate maxval))
2065   ((:pred arm::encode-arm-immediate (:apply lognot maxval))
2066    (cmn idx (:$ (:apply lognot maxval))))
2067   ((:not (:pred arm::encode-arm-immediate (:apply lognot maxval)))
2068    ((:pred (< maxval #x10000))
2069     (movw temp (:$ maxval)))
2070    ((:not (:pred (< maxval #x10000)))
2071     (movw temp (:$ (:apply logand #xffff maxval)))
2072     (movt temp (:$ (:apply ldb (byte 16 16) maxval))))
2073    (cmp idx temp)))
2074  (bhs default))
2075
2076(define-arm-vinsn (ijmp :branch) (()
2077                                  ((idx :u32)))
2078  (add arm::pc arm::pc (:lsl idx (:$ 2)))
2079  (nop))
2080
2081(define-arm-vinsn nop (()
2082                       ())
2083  (nop))
2084
2085
2086
2087     
2088                                   
2089
2090(define-arm-vinsn (cbranch-true :branch) (()
2091                                          ((label :label)
2092                                           (crf :crf)
2093                                           (crbit :u8const)))
2094  (b (:? crbit) label))
2095
2096(define-arm-vinsn (cbranch-false :branch) (()
2097                                           ((label :label)
2098                                            (crf :crf)
2099                                            (crbit :u8const)))
2100  (b (:~ crbit) label))
2101
2102(define-arm-vinsn cond->boolean (((dest :imm))
2103                                 ((cond :u8const)))
2104  (mov dest (:$ arm::nil-value))
2105  (add (:? cond) dest dest (:$ arm::t-offset)))
2106
2107
2108
2109(define-arm-vinsn (lisp-word-ref :predicatable)
2110    (((dest t))
2111     ((base t)
2112      (offset t)))
2113  (ldr dest (:@ base offset)))
2114
2115(define-arm-vinsn (lisp-word-ref-c :predicatable)
2116    (((dest t))
2117     ((base t)
2118      (offset :s16const)))
2119  (ldr dest (:@ base (:$ offset))))
2120
2121 
2122
2123;; Load an unsigned, 32-bit constant into a destination register.
2124(define-arm-vinsn (lri :constant-ref :predicatable)
2125    (((dest :imm))
2126     ((intval :u32const))
2127     ())
2128  ((:pred arm::encode-arm-immediate intval)
2129   (mov dest (:$ intval)))
2130  ((:not (:pred arm::encode-arm-immediate intval))
2131   ((:pred arm::encode-arm-immediate (:apply lognot intval))
2132    (mvn dest (:$ (:apply lognot intval))))
2133   ((:not (:pred arm::encode-arm-immediate (:apply lognot intval)))
2134    ((:and (:pred >= intval 0)
2135           (:pred < intval #x10000))
2136     (movw dest (:$ intval)))
2137    ((:not (:and (:pred >= intval 0)
2138                 (:pred < intval #x10000)))
2139     (movw dest (:$ (:apply logand #xffff intval)))
2140     (movt dest (:$ (:apply ldb (byte 16 16) intval)))))))
2141
2142
2143
2144
2145
2146(define-arm-vinsn (alloc-eabi-c-frame :predicatable)
2147    (()
2148     ((n-c-args :u16const))
2149     ((header :u32)
2150      (prevsp :imm)))
2151  (movw header (:$ (:apply logior (:apply ash (:apply + 1 (:apply logandc2 (:apply + 4 4 1 n-c-args) 1)) arm::num-subtag-bits) arm::subtag-u32-vector)))
2152  (mov prevsp sp)
2153  (str header (:@! sp (:$ (:apply - (:apply ash (:apply + 2 (:apply logandc2 (:apply + 4 4 1 n-c-args) 1)) arm::word-shift)))))
2154  (str prevsp (:@ sp (:$ 4))))
2155
2156(define-arm-vinsn (alloc-variable-eabi-c-frame :predicatable)
2157    (()
2158     ((n-c-args :lisp))
2159     ((header :u32)
2160      (size :imm)
2161      (prevsp :imm)))
2162  (add size n-c-args (:$ (ash (+ 4 4 1) arm::word-shift)))
2163  (bic size size (:$ arm::fixnumone))
2164  (add size size (:$ arm::fixnumone))
2165  (mov prevsp sp)
2166  (mov header (:lsl size (:$ (- arm::num-subtag-bits arm::fixnumshift))))
2167  (add size size (:$ arm::fixnumone))
2168  (orr header header (:$ arm::subtag-u32-vector))
2169  (str header (:-@! sp size))
2170  (str prevsp (:@ sp (:$ 4))))
2171
2172
2173
2174;;; We should rarely have to do this - (#_foo x y (if .. (return-from ...)))
2175;;; is one of the few cases that I can think of - but if we ever do, we
2176;;; might as well exploit the fact that we stored the previous sp at
2177;;; offset 4 in the C frame.
2178(define-arm-vinsn (discard-c-frame :csp :pop :discard :predicatable)
2179    (()
2180     ())
2181  (ldr sp (:@ sp (:$ 4))))
2182
2183;;; Soft-float return.
2184(define-arm-vinsn (gpr-to-single-float :predicatable)
2185    (((dest :single-float))
2186     ((src :u32)))
2187  (fmsr dest src))
2188
2189(define-arm-vinsn (gpr-pair-to-double-float :predicatable)
2190    (((dest :double-float))
2191     ((low :u32)
2192      (high :u32)))
2193  (fmdrr dest low high))
2194
2195
2196(define-arm-vinsn (set-eabi-c-arg :predicatable)
2197    (()
2198     ((argval :u32)
2199      (argnum :u16const)))
2200  (str argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift))))))
2201
2202
2203(define-arm-vinsn (set-single-eabi-c-arg :predicatable)
2204    (()
2205     ((argval :single-float)
2206      (argnum :u16const)))
2207  (fsts argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift))))))
2208
2209(define-arm-vinsn (set-double-eabi-c-arg :predicatable)
2210    (()
2211     ((argval :double-float)
2212      (argnum :u16const)))
2213  (fstd argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift))))))
2214
2215
2216
2217(define-arm-vinsn (load-nil :constant-ref :predicatable)
2218    (((dest t))
2219     ())
2220  (mov dest (:$ arm::nil-value)))
2221
2222(define-arm-vinsn (load-t :constant-ref :predicatable)
2223    (((dest t))
2224     ())
2225  (mov dest (:$ arm::nil-value))
2226  (add dest dest (:$ arm::t-offset)))
2227
2228
2229
2230(define-arm-vinsn (ref-constant :constant-ref :predicatable)
2231    (((dest :lisp))
2232     ((src :s16const)))
2233  (ldr dest (:@ fn (:$ (:apply + arm::misc-data-offset (:apply ash (:apply + src 2) 2))))))
2234
2235(define-arm-vinsn (ref-indexed-constant :predicatable)
2236    (((dest :lisp))
2237     ((idxreg :s32)))
2238  (ldr dest (:@ arm::fn idxreg)))
2239
2240
2241(define-arm-vinsn cons (((dest :lisp))
2242                        ((newcar :lisp)
2243                         (newcdr :lisp))
2244                        ((allocbase :imm)))
2245  (sub allocptr allocptr (:$ (- arm::cons.size arm::fulltag-cons)))
2246  (ldr allocbase (:@ rcontext (:$ arm::tcr.save-allocbase)))
2247  (cmp allocptr allocbase)
2248  (bhi :no-trap)
2249  (uuo-alloc-trap)
2250  :no-trap
2251  (str newcdr (:@ allocptr (:$ arm::cons.cdr)))
2252  (str newcar (:@ allocptr (:$ arm::cons.car)))
2253  (mov dest allocptr)
2254  (bic allocptr allocptr (:$ arm::fulltagmask)))
2255
2256
2257
2258;; subtag had better be a ARM-NODE-SUBTAG of some sort!
2259(define-arm-vinsn %arm-gvector (((dest :lisp))
2260                                ((Rheader :u32) 
2261                                 (nbytes :u32const))
2262                                ((immtemp0 :u32)
2263                                 (nodetemp :lisp)))
2264 
2265  (sub allocptr allocptr (:$ (:apply logand #xff
2266                                     (:apply -
2267                                             (:apply logand (lognot 7)
2268                                                     (:apply + (+ 7 4) nbytes))
2269                                             arm::fulltag-misc))))
2270  ((:pred > (:apply -
2271                    (:apply logand (lognot 7)
2272                            (:apply + (+ 7 4) nbytes))
2273                    arm::fulltag-misc) #xff)
2274   (sub allocptr allocptr (:$ (:apply logand #xff00
2275                                      (:apply -
2276                                              (:apply logand (lognot 7)
2277                                                      (:apply + (+ 7 4) nbytes))
2278                                              arm::fulltag-misc)))))
2279  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
2280  (cmp allocptr dest)
2281  (bhi :no-trap)
2282  (uuo-alloc-trap)
2283  :no-trap
2284  (str Rheader (:@ allocptr (:$ arm::misc-header-offset)))
2285  (mov dest allocptr)
2286  (bic allocptr allocptr (:$ arm::fulltagmask))
2287  ((:not (:pred = nbytes 0))
2288   (mov immtemp0 (:$ (:apply logand #xff (:apply + arm::misc-data-offset nbytes))))
2289   ((:not (:pred = (:apply logand #xff00 (:apply + arm::misc-data-offset nbytes)) 0))
2290    (orr immtemp0 immtemp0 (:$ (:apply logand #xff00 (:apply + arm::misc-data-offset nbytes)))))
2291   :loop
2292   (sub immtemp0 immtemp0 (:$ 4))
2293   (cmp immtemp0 (:$ arm::misc-data-offset))
2294   (ldr nodetemp (:@+ vsp (:$ arm::node-size)))
2295   (str nodetemp (:@ dest immtemp0))
2296   (bne :loop)))
2297
2298;; allocate a small (phys size <= 32K bytes) misc obj of known size/subtag
2299(define-arm-vinsn %alloc-misc-fixed (((dest :lisp))
2300                                     ((Rheader :u32)
2301                                      (nbytes :u32const)))
2302  (sub allocptr allocptr (:$ (:apply
2303                              logand #xff
2304                              (:apply -  (:apply logand (lognot 7)
2305                                                 (:apply + (+ 7 4) nbytes))
2306                                      arm::fulltag-misc))))
2307  ((:pred > (:apply - (:apply logand (lognot 7)
2308                              (:apply + (+ 7 4) nbytes))
2309                    arm::fulltag-misc) #xff)
2310   (sub allocptr allocptr (:$ (:apply logand #xff00
2311                                      (:apply -
2312                                              (:apply logand (lognot 7)
2313                                                      (:apply + (+ 7 4) nbytes))
2314                                              arm::fulltag-misc)))))
2315  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
2316  (cmp allocptr dest)
2317  (bhi :no-trap)
2318  (uuo-alloc-trap)
2319  :no-trap
2320  (str Rheader (:@ allocptr (:$ arm::misc-header-offset)))
2321  (mov dest allocptr)
2322  (bic allocptr allocptr (:$ arm::fulltagmask)))
2323
2324(define-arm-vinsn (vstack-discard :vsp :pop :discard :predicatable)
2325    (()
2326     ((nwords :u32const)))
2327  ((:not (:pred = nwords 0))
2328   (add vsp vsp (:$ (:apply ash nwords arm::word-shift)))))
2329
2330
2331(define-arm-vinsn (lcell-load :predicatable)
2332    (((dest :lisp))
2333     ((cell :lcell)
2334      (top :lcell)))
2335  (ldr dest (:@ vsp (:$ (:apply - 
2336                                (:apply - (:apply calc-lcell-depth top) 4)
2337                                (:apply calc-lcell-offset cell))))))
2338
2339(define-arm-vinsn (vframe-load :predicatable)
2340    (((dest :lisp))
2341     ((frame-offset :u16const)
2342      (cur-vsp :u16const)))
2343  ((:pred < (:apply - (:apply - cur-vsp 4) frame-offset) 4096)
2344   (ldr dest (:@ vsp (:$ (:apply - (:apply - cur-vsp 4) frame-offset)))))
2345  ((:pred >= (:apply - (:apply - cur-vsp 4) frame-offset) 4096)
2346   (movw dest (:$ (:apply - (:apply - cur-vsp 4) frame-offset)))
2347   (ldr dest (:@ vsp dest))))
2348
2349(define-arm-vinsn (lcell-store :predicatable)
2350    (()
2351     ((src :lisp)
2352      (cell :lcell)
2353      (top :lcell)))
2354  (str src (:@ vsp (:$ (:apply - 
2355                               (:apply - (:apply calc-lcell-depth top) 4)
2356                               (:apply calc-lcell-offset cell))))))
2357
2358(define-arm-vinsn (vframe-store :predicatable)
2359    (()
2360     ((src :lisp)
2361      (frame-offset :u16const)
2362      (cur-vsp :u16const)))
2363  ((:pred < (:apply - (:apply - cur-vsp 4) frame-offset) 4096)
2364   (str src (:@ vsp (:$ (:apply - (:apply - cur-vsp 4) frame-offset)))))
2365  ((:pred >= (:apply - (:apply - cur-vsp 4) frame-offset) 4096)
2366   (str rcontext (:@! vsp (:$ (- arm::node-size))))
2367   (movw rcontext (:$ (:apply - cur-vsp frame-offset)))
2368   (str src (:+@ vsp rcontext))
2369   (ldr rcontext (:@+ vsp (:$ arm::node-size))))) 
2370
2371(define-arm-vinsn (load-vframe-address :predicatable)
2372    (((dest :imm))
2373     ((offset :s16const)))
2374  (add dest vsp (:$ offset)))
2375
2376(define-arm-vinsn (copy-lexpr-argument :predicatable)
2377    (()
2378     ()
2379     ((temp :lisp)))
2380  (ldr temp (:@ vsp nargs))
2381  (str temp (:@! vsp (:$ (- arm::node-size)))))
2382
2383;;; Boxing/unboxing of integers.
2384
2385;;; Treat the low 8 bits of VAL as an unsigned integer; set RESULT to the equivalent fixnum.
2386(define-arm-vinsn (u8->fixnum :predicatable)
2387    (((result :imm)) 
2388     ((val :u8)) 
2389     ())
2390  (mov result (:lsl val (:$ 24)))
2391  (mov result (:lsr result (:$ (- 24 arm::fixnumshift)))))
2392
2393;;; Treat the low 8 bits of VAL as a signed integer; set RESULT to the equivalent fixnum.
2394(define-arm-vinsn (s8->fixnum :predicatable)
2395    (((result :imm)) 
2396     ((val :s8)) 
2397     ())
2398  (mov result (:lsl val (:$ 24)))
2399  (mov result (:asr result (:$ (- 24 arm::fixnumshift)))))
2400
2401
2402;;; Treat the low 16 bits of VAL as an unsigned integer; set RESULT to the equivalent fixnum.
2403(define-arm-vinsn (u16->fixnum :predicatable)
2404    (((result :imm)) 
2405     ((val :u16)) 
2406     ())
2407  (mov result (:lsl val (:$ 16)))
2408  (mov result (:lsr result (:$ (- 16 arm::fixnumshift)))))
2409
2410;;; Treat the low 16 bits of VAL as a signed integer; set RESULT to the equivalent fixnum.
2411(define-arm-vinsn (s16->fixnum :predicatable)
2412    (((result :imm)) 
2413     ((val :s16)) 
2414     ())
2415  (mov result (:lsl val (:$ 16)))
2416  (mov result (:asr result (:$ (- 16 arm::fixnumshift)))))
2417
2418(define-arm-vinsn (fixnum->s16 :predicatable)
2419    (((result :s16))
2420     ((src :imm)))
2421  (mov result (:asr src (:$ arm::fixnumshift))))
2422
2423;;; A signed 32-bit untagged value can be at worst a 1-digit bignum.
2424;;; There should be something very much like this that takes a stack-consed
2425;;; bignum result ...
2426(define-arm-vinsn s32->integer (((result :lisp))
2427                                ((src :s32))
2428                                ((temp :s32)))       
2429  (adds temp src src)
2430  (addsvc result temp temp)
2431  (bvc :done)
2432  (movw temp (:$ arm::one-digit-bignum-header))
2433  (add allocptr allocptr (:$ (- arm::fulltag-misc 8)))
2434  (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase)))
2435  (cmp allocptr result)
2436  (bhi :no-trap)
2437  (uuo-alloc-trap)
2438  :no-trap
2439  (str temp (:@ allocptr (:$ arm::misc-header-offset)))
2440  (mov result allocptr)
2441  (bic allocptr allocptr (:$ arm::fulltagmask))
2442  (str src (:@ result (:$ arm::misc-data-offset)))
2443  :done)
2444
2445
2446;;; An unsigned 32-bit untagged value can be either a 1 or a 2-digit bignum.
2447(define-arm-vinsn u32->integer (((result :lisp))
2448                                ((src :u32))
2449                                ((temp :s32)
2450                                 (size :u32)))
2451  (tst src (:$ #xe0000000))
2452  (moveq result (:lsl src (:$ arm::fixnumshift)))
2453  (beq :done)
2454  (cmp src (:$ 0))
2455  (mov temp (:$ arm::subtag-bignum))
2456  (movgt size (:$ (- (* 1 arm::dnode-size) arm::fulltag-misc)))
2457  (orrgt temp temp (:$ (ash 1 arm::num-subtag-bits)))
2458  (movlt size (:$ (- (* 2 arm::dnode-size) arm::fulltag-misc)))
2459  (orrlt temp temp (:$ (ash 2 arm::num-subtag-bits)))
2460  (sub allocptr allocptr size)
2461  (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase)))
2462  (cmp allocptr result)
2463  (bhi :no-trap)
2464  (uuo-alloc-trap)
2465  :no-trap
2466  (str temp (:@ allocptr (:$ arm::misc-header-offset)))
2467  (mov result allocptr)
2468  (bic allocptr allocptr (:$ arm::fulltagmask))
2469  (str src (:@ result (:$ arm::misc-data-offset)))
2470  :done)
2471
2472(define-arm-vinsn (u16->u32 :predicatable)
2473    (((dest :u32))
2474     ((src :u16)))
2475  (mov dest (:$ #xff))
2476  (orr dest dest (:$ #xff00))
2477  (and dest dest src))
2478
2479(define-arm-vinsn (u8->u32 :predicatable)
2480    (((dest :u32))
2481     ((src :u8)))
2482  (and dest src (:$ #xff)))
2483
2484
2485(define-arm-vinsn (s16->s32 :predicatable)
2486    (((dest :s32))
2487     ((src :s16)))
2488  (mov dest (:lsl src (:$ 16)))
2489  (mov dest (:asr src (:$ 16))))
2490
2491(define-arm-vinsn (s8->s32 :predicatable)
2492    (((dest :s32))
2493     ((src :s8)))
2494  (mov dest (:lsl src (:$ 24)))
2495  (mov dest (:asr src (:$ 24))))
2496
2497
2498;;; ... of floats ...
2499
2500;;; Heap-cons a double-float to store contents of FPREG.  Hope that we don't do
2501;;; this blindly.
2502(define-arm-vinsn (double->heap :sets-lr) (((result :lisp)) ; tagged as a double-float
2503                                ((fpreg :double-float)) 
2504                                ((header-temp (:u32 #.arm::imm0))
2505                                 (high (:u32 #.arm::imm1))))
2506  (movw header-temp (:$ arm::double-float-header))
2507  (sub allocptr allocptr (:$ (- arm::double-float.size arm::fulltag-misc)))
2508  (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase)))
2509  (cmp allocptr result)
2510  (bhi :no-trap)
2511  (uuo-alloc-trap)
2512  :no-trap
2513  (str header-temp (:@ allocptr (:$ arm::misc-header-offset)))
2514  (mov result allocptr)
2515  (bic allocptr allocptr (:$ arm::fulltagmask))
2516  (add lr result (:$ arm::double-float.value))
2517  (fstd fpreg (:@ lr (:$ 0)))
2518  (mov lr (:$ 0)))
2519
2520
2521;;; This is about as bad as heap-consing a double-float.  (In terms of
2522;;; verbosity).  Wouldn't kill us to do either/both out-of-line, but
2523;;; need to make visible to compiler so unnecessary heap-consing can
2524;;; be elided.
2525(define-arm-vinsn (single->node :sets-lr)
2526    (((result :lisp)) ; tagged as a single-float
2527     ((fpreg :single-float))
2528     ((header-temp :u32)))
2529  (movw header-temp (:$ arm::single-float-header))
2530  (sub allocptr allocptr (:$ (- arm::single-float.size arm::fulltag-misc)))
2531  (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase)))
2532  (cmp allocptr result)
2533  (bhi :no-trap)
2534  (uuo-alloc-trap)
2535  :no-trap
2536  (str header-temp (:@ allocptr (:$ arm::misc-header-offset)))
2537  (mov result allocptr)
2538  (bic allocptr allocptr (:$ arm::fulltagmask))
2539  (add lr result (:$ arm::single-float.value))
2540  (fsts fpreg (:@ lr (:$ 0)))
2541  (mov lr (:$ 0)))
2542
2543
2544
2545;;; "dest" is preallocated, presumably on a stack somewhere.
2546(define-arm-vinsn (store-double :predicatable :sets-lr)
2547    (()
2548     ((dest :lisp)
2549      (source :double-float)))
2550  (add lr dest (:$ arm::double-float.value))
2551  (fstd source (:@ lr (:$ 0)))
2552  (mov lr (:$ 0)))
2553
2554(define-arm-vinsn (get-double :predicatable :sets-lr)
2555    (((target :double-float))
2556     ((source :lisp)))
2557  (add lr source (:$ arm::double-float.value))
2558  (fldd target (:@ lr (:$ 0)))
2559  (mov lr (:$ 0)))
2560
2561;;; Extract a double-float value, typechecking in the process.
2562;;; IWBNI we could simply call the "trap-unless-typecode=" vinsn here,
2563;;; instead of replicating it ..
2564
2565(define-arm-vinsn (get-double? :sets-lr)
2566    (((target :double-float))
2567     ((source :lisp))
2568     ((tag :u8)))
2569  (and tag source (:$ arm::tagmask))
2570  (cmp tag (:$ arm::tag-misc))
2571  (ldrbeq tag (:@ source (:$ arm::misc-subtag-offset)))
2572  (cmp tag (:$ arm::subtag-double-float))
2573  (beq :ok)
2574  (uuo-error-reg-not-xtype source (:$ arm::subtag-double-float))
2575  :ok
2576  (add lr source (:$ arm::double-float.pad))
2577  (fldd target (:@ lr (:$ (- arm::double-float.value arm::double-float.pad)))))
2578 
2579
2580(define-arm-vinsn double-to-single (((result :single-float))
2581                                    ((arg :double-float)))
2582  (fcvtsd result arg))
2583
2584(define-arm-vinsn (double-to-single-safe :call :subprim-call)
2585    (((result :single-float))
2586     ((arg :double-float))
2587     ((imm :u32)))
2588  (fmrx imm :fpscr)
2589  (bic imm imm (:$ #xff))
2590  (fmxr :fpscr imm)
2591  (fcvtsd result arg)
2592  (sploadlr .SPcheck-fpu-exception)
2593  (blx lr))
2594
2595(define-arm-vinsn single-to-double (((result :double-float))
2596                                    ((arg :single-float)))
2597  (fcvtds result arg))
2598
2599(define-arm-vinsn (single-to-double-safe :call :subprim-call)
2600    (((result :double-float))
2601     ((arg :single-float))
2602     ((imm :u32)))
2603  (fmrx imm :fpscr)
2604  (bic imm imm (:$ #xff))
2605  (fmxr :fpscr imm)
2606  (fcvtds result arg)
2607  (sploadlr .SPcheck-fpu-exception)
2608  (blx lr))
2609
2610(define-arm-vinsn (store-single :predicatable :sets-lr)
2611    (()
2612     ((dest :lisp)
2613      (source :single-float)))
2614  (add arm::lr dest (:$ arm::single-float.value))
2615  (fsts source (:@ arm::lr (:$ 0)))
2616  (mov lr (:$ 0)))
2617
2618(define-arm-vinsn (get-single :predicatable :sets-lr)
2619    (((target :single-float))
2620     ((source :lisp)))
2621  (add arm::lr source (:$ arm::single-float.value))
2622  (flds target (:@ arm::lr (:$ 0)))
2623  (mov lr (:$ 0)))
2624
2625;;; ... of characters ...
2626
2627
2628(define-arm-vinsn (character->fixnum :predicatable)
2629    (((dest :lisp))
2630     ((src :lisp))
2631     ())
2632  (bic dest src (:$ arm::subtag-mask))
2633  (mov dest (:lsr dest (:$ (- arm::charcode-shift arm::fixnumshift)))))
2634
2635(define-arm-vinsn (character->code :predicatable)
2636    (((dest :u32))
2637     ((src :lisp)))
2638  (mov dest (:lsr src (:$ arm::charcode-shift))))
2639
2640
2641(define-arm-vinsn fixnum->char (((dest :lisp))
2642                                ((src :imm))
2643                                ((tempa :u32)
2644                                 (tempb :u32)))
2645  (movw tempb (:$ #x7fff))
2646  (mov tempa (:lsr src (:$ (+ arm::fixnumshift 1))))
2647  (cmp tempa tempb)
2648  (mov tempa (:lsr src (:$ (+ arm::fixnumshift 11))))
2649  (beq :bad)
2650  (cmp tempa (:$ 27))
2651  (mov dest (:lsl src (:$ (- arm::charcode-shift arm::fixnumshift))))
2652  :bad
2653  (moveq dest (:$ arm::nil-value))
2654  (addne dest dest (:$ arm::subtag-character)))
2655
2656;;; src is known to be a code for which CODE-CHAR returns non-nil.
2657(define-arm-vinsn (code-char->char :predicatable)
2658    (((dest :lisp))
2659     ((src :imm))
2660     ())
2661  (mov dest (:lsl src (:$ (- arm::charcode-shift arm::fixnum-shift))))
2662  (orr dest dest (:$ arm::subtag-character)))
2663
2664(define-arm-vinsn (u32->char :predicatable)
2665    (((dest :lisp))
2666     ((src :u32))
2667     ())
2668  (mov dest (:lsl src (:$ arm::charcode-shift)))
2669  (orr dest dest (:$ arm::subtag-character)))
2670
2671;; ... Macptrs ...
2672
2673(define-arm-vinsn (deref-macptr :predicatable)
2674    (((addr :address))
2675     ((src :lisp))
2676     ())
2677  (ldr addr (:@ src (:$ arm::macptr.address))))
2678
2679(define-arm-vinsn (set-macptr-address :predicatable)
2680    (()
2681     ((addr :address)
2682      (src :lisp))
2683     ())
2684  (str addr (:@ src (:$ arm::macptr.address))))
2685
2686
2687(define-arm-vinsn macptr->heap (((dest :lisp))
2688                                ((address :address))
2689                                ((header :u32)))
2690  (movw header (:$ arm::macptr-header))
2691  (sub allocptr allocptr (:$ (- arm::macptr.size arm::fulltag-misc)))
2692  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
2693  (cmp allocptr dest)
2694  (bhi :no-trap)
2695  (uuo-alloc-trap)
2696  :no-trap
2697  (str header (:@ allocptr (:$ arm::misc-header-offset)))
2698  (mov dest allocptr)
2699  (bic allocptr allocptr (:$ arm::fulltagmask))
2700  ;; It's not necessary to zero out the domain/type fields, since newly
2701  ;; heap-allocated memory's guaranteed to be 0-filled.
2702  (str address (:@ dest (:$ arm::macptr.address))))
2703
2704(define-arm-vinsn (macptr->stack :predicatable)
2705    (((dest :lisp))
2706     ((address :address))
2707     ((header :u32)))
2708  (movw header (:$ arm::macptr-header))
2709  (str header (:@! sp (:$ (- arm::macptr.size))))
2710  (mov header (:$ 0))
2711  (str header  (:@ sp (:$ (+ arm::fulltag-misc arm::macptr.domain))))
2712  (str header  (:@ sp (:$ (+ arm::fulltag-misc arm::macptr.type))))
2713  (str address (:@ sp (:$ (+ arm::fulltag-misc arm::macptr.address))))
2714  (add dest sp (:$ arm::fulltag-misc)))
2715
2716
2717 
2718
2719
2720(define-arm-vinsn (adjust-vsp :predicatable :vsp :pop :discard)
2721    (()
2722     ((amount :s16const)))
2723  (add vsp vsp (:$ amount)))
2724
2725(define-arm-vinsn (adjust-sp :predicatable)
2726    (()
2727     ((amount :s16const)))
2728  (add sp sp (:$ amount)))
2729
2730;; Arithmetic on fixnums & unboxed numbers
2731
2732(define-arm-vinsn (u32-lognot :predicatable)
2733    (((dest :u32))
2734     ((src :u32))
2735     ())
2736  (mvn dest src))
2737
2738(define-arm-vinsn (fixnum-lognot :predicatable)
2739    (((dest :imm))
2740     ((src :imm))
2741     ((temp :u32)))
2742  (mvn temp src)
2743  (bic dest temp (:$ arm::fixnummask)))
2744
2745
2746(define-arm-vinsn negate-fixnum-overflow-inline (((dest :lisp))
2747                                                 ((src :imm))
2748                                                 ((unboxed :s32)
2749                                                  (header :u32)))
2750  (rsbs dest src (:$ 0))
2751  (bvc :done)
2752  (mov unboxed (:asr dest (:$ arm::fixnumshift)))
2753  (eor unboxed unboxed (:$ #xc0000000))
2754  (movw header (:$ arm::one-digit-bignum-header))
2755  (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc)))
2756  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
2757  (cmp allocptr dest)
2758  (bhi :no-trap)
2759  (uuo-alloc-trap)
2760  :no-trap
2761  (str header (:@ allocptr (:$ arm::misc-header-offset)))
2762  (mov dest allocptr)
2763  (bic allocptr allocptr (:$ arm::fulltagmask))
2764  (str unboxed (:@ dest (:$ arm::misc-data-offset)))
2765  :done)
2766
2767(define-arm-vinsn (negate-fixnum-overflow-ool :call :subprim-call)
2768    (((result (:lisp #.arm::arg_z)))
2769     ((src :imm))
2770     )
2771  (rsbs arm::arg_z src (:$ 0))
2772  (sploadlrvs .SPfix-overflow)
2773  (blxvs lr))
2774 
2775                                                 
2776                                       
2777(define-arm-vinsn (negate-fixnum-no-ovf :predicatable)
2778    (((dest :lisp))
2779     ((src :imm)))
2780  (rsb dest src (:$ 0)))
2781 
2782
2783(define-arm-vinsn (logior-immediate :predicatable)
2784    (((dest :imm))
2785     ((src :imm)
2786      (imm :u32const)))
2787  (orr dest src (:$ imm)))
2788
2789                           
2790                           
2791(define-arm-vinsn (%logior2 :predicatable)
2792    (((dest :imm))
2793     ((x :imm)
2794      (y :imm))
2795     ())
2796  (orr dest x y))
2797
2798(define-arm-vinsn (logand-immediate :predicatable)
2799    (((dest :imm))
2800     ((src :imm)
2801      (imm :u32const)))
2802  (and dest src (:$ imm)))
2803
2804
2805(define-arm-vinsn (%logand2 :predicatable)
2806    (((dest :imm))
2807     ((x :imm)
2808      (y :imm))
2809     ())
2810  (and dest x y))
2811
2812(define-arm-vinsn (logxor-immediate :predicatable)
2813    (((dest :imm))
2814     ((src :imm)
2815      (imm :u32const)))
2816  (eor dest src (:$ imm)))
2817                                   
2818
2819                               
2820
2821(define-arm-vinsn (%logxor2 :predicatable)
2822    (((dest :imm))
2823     ((x :imm)
2824      (y :imm))
2825     ())
2826  (eor dest x y))
2827
2828;;; ARM register shifts shift by the low byte of RS.
2829(define-arm-vinsn (%ilsl :predicatable)
2830    (((dest :imm))
2831     ((count :imm)
2832      (src :imm))
2833     ((temp :u32)))
2834  (mov temp (:asr count (:$ arm::fixnumshift)))
2835  (mov dest (:lsl src temp)))
2836
2837;;; Shift by a constant = -> shift by 32.  Don't do that.
2838(define-arm-vinsn (%ilsl-c :predicatable)
2839    (((dest :imm))
2840     ((count :u8const)
2841      (src :imm)))
2842  ((:pred = count 0)
2843   (mov dest src))
2844  ((:not (:pred = count 0))
2845   (mov dest (:lsl src (:$ (:apply logand count 31))))))
2846
2847
2848(define-arm-vinsn (%ilsr-c :predicatable)
2849    (((dest :imm))
2850     ((count :u8const)
2851      (src :imm))
2852     ((temp :s32)))
2853  (mov temp (:lsr src (:$ count)))
2854  (bic dest temp (:$ arm::fixnummask)))
2855
2856
2857(define-arm-vinsn (%iasr :predicatable)
2858    (((dest :imm))
2859     ((count :imm)
2860      (src :imm))
2861     ((temp :s32)))
2862  (mov temp (:asr count (:$ arm::fixnumshift)))
2863  (mov temp (:asr src temp))
2864  (bic dest temp (:$ arm::fixnummask)))
2865
2866(define-arm-vinsn %iasr-c (((dest :imm))
2867                           ((count :u8const)
2868                            (src :imm))
2869                           ((temp :s32)))
2870  ((:pred = count 0)
2871   (mov dest src))
2872  ((:not (:pred = count 0))
2873   (mov temp (:asr src (:$ count)))
2874   (bic dest temp (:$ arm::fixnummask))))
2875
2876(define-arm-vinsn (%ilsr :predicatable)
2877    (((dest :imm))
2878     ((count :imm)
2879      (src :imm))
2880     ((temp :s32)))
2881  (mov temp (:asr count (:$ arm::fixnumshift)))
2882  (mov temp (:lsr src temp))
2883  (bic dest temp (:$ arm::fixnummask)))
2884
2885
2886(define-arm-vinsn (%ilsr-c :predicatable)
2887    (((dest :imm))
2888     ((count :u8const)
2889      (src :imm))
2890     ((temp :s32)))
2891  ((:pred = count 0)
2892   (mov dest src))
2893  ((:not (:pred = count 0))
2894   (mov temp (:lsr src (:$ count)))
2895   (bic dest temp (:$ arm::fixnummask))))
2896
2897(define-arm-vinsn (natural-shift-left :predicatable)
2898    (((dest :u32))
2899     ((src :u32)
2900      (count :u8const)))
2901  ((:pred = count 0)
2902   (mov dest src))
2903  ((:not (:pred = count 0))
2904   (mov dest (:lsl src (:$ count)))))
2905
2906(define-arm-vinsn (natural-shift-right :predicatable)
2907    (((dest :u32))
2908     ((src :u32)
2909      (count :u8const)))
2910  ((:pred = count 0)
2911   (mov dest src))
2912  ((:not (:pred = count 0))
2913   (mov dest (:lsr src (:$ count)))))
2914
2915
2916(define-arm-vinsn trap-unless-simple-array-2 (()
2917                                              ((object :lisp)
2918                                               (rexpected-flags :imm))
2919                                              ((tag :u8)
2920                                               (flags :u32)))
2921  (and tag object (:$ arm::tagmask))
2922  (cmp tag (:$ arm::tag-misc))
2923  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
2924  (cmp tag (:$ arm::subtag-arrayH))
2925  (bne :bad-if-ne)
2926  (mov flags (:$ (ash 2 arm::fixnumshift)))
2927  (ldr tag (:@ object (:$ arm::arrayH.rank)))
2928  (cmp tag flags)
2929  (beq :ok)
2930  (uuo-error-array-rank flags object)
2931  :ok
2932  (ldr flags (:@ object (:$ arm::arrayH.flags)))
2933  (cmp flags rexpected-flags)
2934  :bad-if-ne
2935  (beq :done)
2936  (uuo-error-array-flags rexpected-flags object )
2937  :done)
2938
2939(define-arm-vinsn trap-unless-simple-array-3 (()
2940                                              ((object :lisp)
2941                                               (rexpected-flags :imm))
2942                                              ((tag :u8)
2943                                               (flags :u32)))
2944  (and tag object (:$ arm::tagmask))
2945  (cmp tag (:$ arm::tag-misc))
2946  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
2947  (cmp tag (:$ arm::subtag-arrayH))
2948  (bne :bad-if-ne)
2949  (ldr tag (:@ object (:$ arm::arrayH.rank)))
2950  (mov flags (:$ (ash 3 arm::fixnumshift)))
2951  (cmp tag flags)
2952  (beq :rank-ok)
2953  (uuo-error-array-rank flags object)
2954  :rank-ok
2955  (ldr flags (:@ object (:$ arm::arrayH.flags)))
2956  (cmp rexpected-flags flags)
2957  :bad-if-ne
2958  (beq :done)
2959  (uuo-error-array-flags rexpected-flags object)
2960  :done)
2961 
2962 
2963 
2964 
2965(define-arm-vinsn (sign-extend-halfword :predicatable)
2966    (((dest :imm))
2967     ((src :imm)))
2968  (mov dest (:lsl src (:$ (- 16 arm::fixnumshift))))
2969  (mov dest (:asr dest (:$ (- 16 arm::fixnumshift)))))
2970
2971
2972                           
2973
2974(define-arm-vinsn (fixnum-add :predicatable)
2975    (((dest t))
2976     ((x t)
2977      (y t)))
2978  (add dest x y))
2979
2980
2981(define-arm-vinsn fixnum-add-overflow-ool (((result (:lisp #.arm::arg_z)))
2982                                           ((x :imm)
2983                                            (y :imm))
2984                                           ())
2985  (adds arm::arg_z x y)
2986  (sploadlrvs .SPfix-overflow)
2987  (blxvs lr))
2988
2989(define-arm-vinsn fixnum-add-overflow-inline (((dest :lisp))
2990                                              ((x :imm)
2991                                               (y :imm))
2992                                              ((unboxed :s32)
2993                                               (header :u32)))
2994  (adds dest x y)
2995  (bvc :done)
2996  (mov unboxed (:asr dest (:$ arm::fixnumshift)))
2997  (movw header (:$ arm::one-digit-bignum-header))
2998  (eor unboxed unboxed (:$ #xc0000000))
2999  (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc)))
3000  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
3001  (cmp allocptr dest)
3002  (bhi :no-trap)
3003  (uuo-alloc-trap)
3004  :no-trap
3005  (str header (:@ allocptr (:$ arm::misc-header-offset)))
3006  (mov dest allocptr)
3007  (bic allocptr allocptr (:$ arm::fulltagmask))
3008  (str unboxed (:@ dest (:$ arm::misc-data-offset)))
3009  :done)
3010
3011(define-arm-vinsn fixnum-add-overflow-inline-skip (((dest :lisp))
3012                                                   ((x :imm)
3013                                                    (y :imm)
3014                                                    (target :label))
3015                                                   ((unboxed :s32)
3016                                                    (header :u32)))
3017  (adds dest x y)
3018  (bvc target)
3019  (mov unboxed (:asr dest (:$ arm::fixnumshift)))
3020  (movw header (:$ arm::one-digit-bignum-header))
3021  (eor unboxed unboxed (:$ #xc0000000))
3022  (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc)))
3023  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocptr)))
3024  (cmp allocptr dest)
3025  (bhi :no-trap)
3026  (uuo-alloc-trap)
3027  :no-trap
3028  (str header (:@ allocptr (:$ arm::misc-header-offset)))
3029  (mov dest allocptr)
3030  (bic allocptr allocptr (:$ arm::fulltagmask))
3031  (str unboxed (:@ dest (:$ arm::misc-data-offset)))
3032  (b target))
3033 
3034
3035 
3036
3037;;;  (setq dest (- x y))
3038(define-arm-vinsn (fixnum-sub :predicatable)
3039    (((dest t))
3040     ((x t)
3041      (y t)))
3042  (sub dest x y))
3043
3044(define-arm-vinsn (fixnum-sub-from-constant :predicatable)
3045    (((dest :imm))
3046     ((x :s16const)
3047      (y :imm)))
3048  (rsb dest y (:$ (:apply ash x arm::fixnumshift))))
3049
3050
3051
3052
3053(define-arm-vinsn (fixnum-sub-overflow-ool :call :subprim-call)
3054    (((result (:lisp #.arm::arg_z)))
3055     ((x :imm)
3056      (y :imm)))
3057  (subs arm::arg_z x y)
3058  (sploadlrvs .SPfix-overflow)
3059  (blxvs lr))
3060
3061(define-arm-vinsn fixnum-sub-overflow-inline (((dest :lisp))
3062                                              ((x :imm)
3063                                               (y :imm))
3064                                              ((cr0 (:crf 0))
3065                                               (unboxed :s32)
3066                                               (header :u32)))
3067  (subs dest x y)
3068  (bvc :done)
3069  (mov unboxed (:asr dest (:$ arm::fixnumshift)))
3070  (movw header (:$ arm::one-digit-bignum-header))
3071  (eor unboxed unboxed (:$ #xc0000000))
3072  (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc)))
3073  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
3074  (cmp allocptr dest)
3075  (bhi :no-trap)
3076  (uuo-alloc-trap)
3077  :no-trap
3078  (str header (:@ allocptr (:$ arm::misc-header-offset)))
3079  (mov dest allocptr)
3080  (bic allocptr allocptr (:$ arm::fulltagmask))
3081  (str unboxed (:@ dest (:$ arm::misc-data-offset)))
3082  :done)
3083
3084(define-arm-vinsn fixnum-sub-overflow-inline-skip (((dest :lisp))
3085                                                   ((x :imm)
3086                                                    (y :imm)
3087                                                    (target :label))
3088                                                   ((unboxed :s32)
3089                                                    (header :u32)))
3090  (subs dest x y)
3091  (bvc target)
3092  (mov unboxed (:asr dest (:$ arm::fixnumshift)))
3093  (movw header (:$ arm::one-digit-bignum-header))
3094  (eor unboxed unboxed (:$ #xc0000000))
3095  (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc)))
3096  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
3097  (cmp allocptr dest)
3098  (bhi :no-trap)
3099  (uuo-alloc-trap)
3100  :no-trap
3101  (str header (:@ allocptr (:$ arm::misc-header-offset)))
3102  (mov dest allocptr)
3103  (bic allocptr allocptr (:$ arm::fulltagmask))
3104  (str unboxed (:@ dest (:$ arm::misc-data-offset)))
3105  (b target))
3106
3107;;; This is, of course, also "subtract-immediate."
3108(define-arm-vinsn (add-immediate :predicatable)
3109    (((dest t))
3110     ((src t)
3111      (imm :s32const)))
3112  (add dest src (:$ imm)))
3113
3114(define-arm-vinsn (multiply-fixnums :predicatable)
3115    (((dest :imm))
3116     ((a :imm)
3117      (b :imm))
3118     ((unboxed :s32)))
3119  (mov unboxed (:asr b (:$ arm::fixnumshift)))
3120  (mul dest a unboxed))
3121
3122
3123
3124;;; Mask out the code field of a base character; the result
3125;;; should be EXACTLY = to subtag-base-char
3126(define-arm-vinsn (mask-base-char :predicatable)
3127    (((dest :u32))
3128     ((src :imm)))
3129  (and dest src (:$ arm::subtag-mask)))
3130
3131
3132(define-arm-vinsn istruct-type (((dest :lisp))
3133                                ((val :lisp))
3134                                ((temp :u8)))
3135  (and temp val (:$ arm::tagmask))
3136  (cmp temp (:$ arm::tag-misc))
3137  (ldrbeq temp (:@ val (:$ arm::misc-subtag-offset)))
3138  (cmp temp (:$ arm::subtag-istruct))
3139  (movne dest (:$ arm::nil-value))
3140  (ldreq dest (:@ val (:$ arm::misc-data-offset))))
3141 
3142 
3143;; Boundp, fboundp stuff.
3144(define-arm-vinsn (ref-symbol-value :call :subprim-call)
3145    (((val :lisp))
3146     ((sym (:lisp (:ne val)))))
3147  (sploadlr .SPspecrefcheck)
3148  (blx lr))
3149
3150(define-arm-vinsn ref-symbol-value-inline (((dest :lisp))
3151                                           ((src (:lisp (:ne dest))))
3152                                           ((table :imm)
3153                                            (idx :imm)))
3154  (ldr idx (:@ src (:$ arm::symbol.binding-index)))
3155  (ldr table (:@ rcontext (:$ arm::tcr.tlb-limit)))
3156  (cmp idx table)
3157  (ldr table (:@ rcontext (:$ arm::tcr.tlb-pointer)))
3158  (movhs idx (:$ 0))
3159  (ldr dest (:@ table idx))
3160  (cmp dest (:$ arm::subtag-no-thread-local-binding))
3161  (ldreq dest (:@ src (:$ arm::symbol.vcell)))
3162  (cmp dest (:$ arm::unbound-marker))
3163  (bne :bound)
3164  (uuo-error-unbound src)
3165  :bound)
3166
3167(define-arm-vinsn (%ref-symbol-value :call :subprim-call)
3168    (((val :lisp))
3169     ((sym (:lisp (:ne val)))))
3170  (sploadlr .SPspecref)
3171  (blx lr))
3172
3173(define-arm-vinsn %ref-symbol-value-inline (((dest :lisp))
3174                                            ((src (:lisp (:ne dest))))
3175                                            ((table :imm)
3176                                             (idx :imm)))
3177  (ldr idx (:@ src (:$ arm::symbol.binding-index)))
3178  (ldr table (:@ rcontext (:$ arm::tcr.tlb-limit)))
3179  (cmp idx table)
3180  (ldr table (:@ rcontext (:$ arm::tcr.tlb-pointer)))
3181  (movhs idx (:$ 0))
3182  (ldr dest (:@ table idx))
3183  (cmp dest (:$ arm::subtag-no-thread-local-binding))
3184  (ldreq dest (:@ src (:$ arm::symbol.vcell))))
3185
3186(define-arm-vinsn (setq-special :call :subprim-call)
3187    (()
3188     ((sym :lisp)
3189      (val :lisp)))
3190  (sploadlr .SPspecset)
3191  (blx lr))
3192
3193
3194(define-arm-vinsn symbol-function (((val :lisp))
3195                                   ((sym (:lisp (:ne val))))
3196                                   ((crf :crf)
3197                                    (tag :u32)))
3198  (ldr val (:@ sym (:$ arm::symbol.fcell)))
3199  (and tag val (:$ arm::tagmask))
3200  (cmp tag (:$ arm::tag-misc))
3201  (ldrbeq tag (:@ val (:$ arm::misc-subtag-offset)))
3202  (cmp tag (:$ arm::subtag-function))
3203  (beq :defined)
3204  (uuo-error-udf sym)
3205  :defined)
3206
3207(define-arm-vinsn (temp-push-unboxed-word :push :word :csp :predicatable)
3208   
3209    (()
3210     ((w :u32))
3211     ((header :u32)))
3212  (movw header (:$ (logior (ash 1 arm::num-subtag-bits) arm::subtag-u32-vector)))
3213  (str header (:@! sp (:$ (- arm::dnode-size))))
3214  (str w (:@ sp (:$ 4))))
3215
3216(define-arm-vinsn (temp-pop-unboxed-word :pop :word :csp :predicatable)
3217   
3218    (((w :u32))
3219     ())
3220  (ldr w (:@ sp (:$ 4)))
3221  (add sp sp (:$ arm::dnode-size)))
3222
3223(define-arm-vinsn (temp-push-double-float :push :doubleword :csp :predicatable)
3224   
3225    (()
3226     ((d :double-float))
3227     ((header :u32)))
3228  (movw header (:$ arm::double-float-header))
3229  (str header (:@! sp (:$ (- (* 2 arm::dnode-size)))))
3230  (fstd d (:@ sp (:$ 8))))
3231
3232(define-arm-vinsn (temp-pop-double-float :pop :doubleword :csp :predicatable)
3233   
3234    (()
3235     ((d :double-float)))
3236  (fldd d (:@ sp (:$ 8)))
3237  (add sp sp (:$ (* 2 arm::dnode-size))))
3238
3239
3240(define-arm-vinsn (temp-push-single-float :push :word :csp :predicatable)
3241   
3242    (()
3243     ((s :single-float))
3244     ((header :u32)))
3245  (movw header (:$ arm::single-float-header))
3246  (str header (:@! sp (:$ (- arm::dnode-size))))
3247  (fsts s (:@ sp (:$ 4))))
3248
3249
3250(define-arm-vinsn (temp-pop-single-float :pop :word :csp :predicatable)
3251   
3252    (()
3253     ((s :single-float)))
3254  (flds s (:@ sp (:$ 4)))
3255  (add sp sp (:$ arm::dnode-size)))
3256
3257
3258
3259(define-arm-vinsn (%current-frame-ptr :predicatable)
3260    (((dest :imm))
3261     ())
3262  (mov dest arm::sp))
3263
3264(define-arm-vinsn (%current-tcr :predicatable)
3265    (((dest :imm))
3266     ())
3267  (mov dest rcontext))
3268
3269(define-arm-vinsn (dpayback :call :subprim-call) (()
3270                                                  ((n :s16const))
3271                                                  ((temp (:u32 #.arm::imm0))))
3272  ((:pred > n 1)
3273   (mov temp (:$ n))
3274   (sploadlr .SPunbind-n))
3275  ((:pred = n 1)
3276   (sploadlr .SPunbind))
3277  (blx lr))
3278
3279(define-arm-vinsn (zero-double-float-register :predicatable)
3280    (((dest :double-float))
3281     ())
3282  (fcpyd dest arm::double-float-zero))
3283
3284(define-arm-vinsn (zero-single-float-register :predicatable)
3285    (((dest :single-float))
3286     ())
3287  (fcpys dest arm::single-float-zero))
3288
3289(define-arm-vinsn (load-double-float-constant-from-data :predicatable)
3290    (((dest :double-float))
3291     ((high :u32const)
3292      (low :u32const)))
3293  (fldd dest (:= :x))
3294  (:data)
3295  :x
3296  (:word low)
3297  (:word high)
3298  :code)
3299
3300(define-arm-vinsn (load-single-float-constant :predicatable)
3301    (((dest :single-float))
3302     ((src t)))
3303  (fmsr dest src))
3304
3305(define-arm-vinsn (load-indexed-node :predicatable)
3306    (((node :lisp))
3307     ((base :lisp)
3308      (offset :s16const)))
3309  (ldr node (:@ base (:$ offset))))
3310
3311(define-arm-vinsn check-exact-nargs (()
3312                                     ((n :u16const)))
3313  (cmp nargs (:$ (:apply ash n 2)))
3314  (beq :ok)
3315  (uuo-error-wrong-nargs (:? ne))
3316  :ok)
3317
3318(define-arm-vinsn check-exact-nargs-large (()
3319                                           ((n :u16const))
3320                                           ((preserve (:u32 #.arm::nargs))
3321                                            (temp :u32)))
3322  (movw temp (:$ (:apply ash n 2)))
3323  (cmp nargs temp)
3324  (beq :ok)
3325  (uuo-error-wrong-nargs (:? ne))
3326  :ok)
3327
3328(define-arm-vinsn check-min-nargs (()
3329                                   ((min :u16const)))
3330  (cmp nargs (:$ (:apply ash min 2)))
3331  (bhs :ok)
3332  (uuo-error-wrong-nargs (:? lo))
3333  :ok)
3334
3335(define-arm-vinsn check-min-nargs-large (()
3336                                         ((min :u16const))
3337                                         ((preserve (:u32 #.arm::nargs))
3338                                          (temp :u32)))
3339  (movw temp (:$ (:apply ash min 2)))
3340  (cmp nargs temp)
3341  (bhs :ok)
3342  (uuo-error-wrong-nargs (:? lo))
3343  :ok)
3344
3345
3346(define-arm-vinsn check-max-nargs (()
3347                                   ((max :u16const)))
3348  (cmp nargs (:$ (:apply ash max 2)))
3349  (bls :ok)
3350  (uuo-error-wrong-nargs (:? hi))
3351  :ok)
3352
3353(define-arm-vinsn check-max-nargs-large (()
3354                                         ((max :u16const))
3355                                         ((preserve (:u32 #.arm::nargs))
3356                                          (temp :u32)))
3357  (movw temp (:$ (:apply ash max 2)))
3358  (cmp nargs temp)
3359  (bls :ok)
3360  (uuo-error-wrong-nargs (:? hi))
3361  :ok)
3362
3363;;; Save context and establish FN.  The current VSP is the the
3364;;; same as the caller's, e.g., no arguments were vpushed.
3365(define-arm-vinsn save-lisp-context-vsp (()
3366                                         ()
3367                                         ((imm :u32)))
3368  (mov imm (:$ arm::lisp-frame-marker))
3369  (stmdb (:! sp) (imm vsp fn lr))
3370  (mov fn nfn))
3371
3372
3373
3374(define-arm-vinsn save-lisp-context-offset (()
3375                                            ((nbytes-vpushed :u16const))
3376                                            ((imm (:u32 #.arm::imm1))
3377                                             (clobbered (:u32 #.arm::imm0))))
3378  ((:pred arm::encode-arm-immediate nbytes-vpushed)
3379   (add imm vsp (:$ nbytes-vpushed)))
3380  ((:not (:pred arm::encode-arm-immediate nbytes-vpushed))
3381   (movw imm (:$ nbytes-vpushed))
3382   (add imm imm vsp))
3383  (mov imm0 (:$ arm::lisp-frame-marker))
3384  (stmdb (:! sp) (imm0 imm fn lr))
3385  (mov fn nfn))
3386
3387(define-arm-vinsn save-lisp-context-variable (()
3388                                              ()
3389                                              ((imm (:u32 #.arm::imm1))))
3390  (subs imm nargs (:$ (ash $numarmargregs arm::word-shift)))
3391  (movmi imm (:$ 0))
3392  (add imm imm vsp)
3393  (mov imm0 (:$ arm::lisp-frame-marker))
3394  (stmdb (:! sp) (imm0 imm fn lr))
3395  (mov fn nfn)) 
3396
3397
3398
3399 
3400(define-arm-vinsn save-cleanup-context (()
3401                                        ())
3402  (mov temp2 (:$ 0))
3403  (mov imm0 (:$ arm::lisp-frame-marker)) 
3404  (stmdb (:! sp) (imm0 vsp fn lr))
3405  (str temp2 (:@ sp (:$ arm::lisp-frame.savefn))))
3406
3407
3408
3409;; Vpush the argument registers.  We got at least "min-fixed" args;
3410;; that knowledge may help us generate better code.
3411(define-arm-vinsn save-lexpr-argregs
3412    (()
3413     ((min-fixed :u16const))
3414     ((entry-vsp (:u32 #.arm::imm1))
3415      (arg-temp (:u32 #.arm::imm0))
3416      (preserve (:u32 #.arm::nargs))
3417      (other-temp :imm)))
3418  ((:pred >= min-fixed $numarmargregs)
3419   (stmdb (:! vsp) (arg_z arg_y arg_x)))
3420  ((:pred = min-fixed 2)                ; at least 2 args
3421   (cmp nargs (:$ (ash 2 arm::word-shift)))
3422   (strne arg_x (:@! vsp (:$ -4)))
3423   (stmdb (:! vsp) (arg_z arg_y)))
3424  ((:pred = min-fixed 1)                ; at least one arg
3425   (cmp nargs (:$ (ash 2 arm::word-shift)))
3426   (strlo arg_z (:@! vsp (:$ (- arm::node-size))))
3427   (stmdbeq (:! vsp) (arg_z arg_y))
3428   (stmdbhi (:! vsp) (arg_z arg_y arg_x)))
3429  ((:pred = min-fixed 0)
3430   (cmp nargs (:$ 0))
3431   (beq :done)
3432   (cmp nargs (:$ (ash 2 arm::word-shift)))
3433   (strlo arg_z (:@! vsp (:$ (- arm::node-size))))
3434   (stmdbeq (:! vsp) (arg_z arg_y))
3435   (stmdbhi (:! vsp) (arg_z arg_y arg_x))
3436   :done
3437   )
3438  ((:pred = min-fixed 0)
3439   (str nargs (:@! vsp (:$ -4))))
3440  ((:not (:pred = min-fixed 0))
3441   (sub arg-temp nargs (:$ (:apply ash min-fixed arm::word-shift)))
3442   (str arg-temp (:@! vsp (:$ -4))))
3443  (add entry-vsp vsp nargs)
3444  (mov other-temp (:$ (- arm::nil-value arm::fulltag-nil)))
3445  (ldr other-temp (:@ other-temp (:$ (arm::%kernel-global 'arm::ret1valaddr))))
3446  (add entry-vsp entry-vsp (:$ 4))
3447  (cmp other-temp lr)
3448  (mov arg-temp (:$ arm::lisp-frame-marker))
3449  (stmdb (:! sp) (arg-temp entry-vsp fn lr))
3450  (mov fn (:$ 0))
3451  (moveq lr (:$ (- arm::nil-value arm::fulltag-nil)))
3452  (ldreq lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return))))
3453  (stmdbeq (:! sp) (arg-temp entry-vsp fn lr))
3454  (moveq lr other-temp)
3455  (movne lr (:$ (- arm::nil-value arm::fulltag-nil)))
3456  (ldrne lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return1v))))
3457  )
3458
3459
3460
3461(define-arm-vinsn (jump-return-pc :jumpLR :predicatable)
3462    (()
3463     ())
3464  (bx lr))
3465
3466(define-arm-vinsn (restore-full-lisp-context :lispcontext :pop :csp :lrRestore :predicatable)
3467    (()
3468     ())
3469  (ldmia (:! sp) (imm0 vsp fn lr)))
3470
3471
3472
3473
3474
3475(define-arm-vinsn (popj :lispcontext :pop :csp :lrRestore :jumpLR :predicatable)
3476    (() 
3477     ())
3478  (ldmia (:! sp) (imm0 vsp fn pc)))
3479
3480;;; Exiting from an UNWIND-PROTECT cleanup is similar to
3481;;; (and a little simpler than) returning from a function.
3482(define-arm-vinsn restore-cleanup-context (()
3483                                           ())
3484  (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
3485  (add sp sp (:$ arm::lisp-frame.size)))
3486
3487
3488
3489(define-arm-vinsn default-1-arg (()
3490                                 ((min :u16const)))
3491  (cmp nargs (:$ (:apply ash min 2)))
3492  (bne :done)
3493  ((:pred >= min 3)
3494   (str arg_x (:@! vsp (:$ (- arm::node-size)))))
3495  ((:pred >= min 2)
3496   (mov arg_x arg_y))
3497  ((:pred >= min 1)
3498   (mov arg_y arg_z))
3499  (mov arm::arg_z (:$ arm::nil-value))
3500  :done)
3501
3502(define-arm-vinsn default-2-args (()
3503                                  ((min :u16const)))
3504  (cmp nargs (:$ (:apply ash (:apply 1+ min) 2)))
3505  (bgt :done)
3506  (beq :one)
3507  ;; We got "min" args; arg_y & arg_z default to nil
3508  ((:pred >= min 3)
3509   (str arg_x (:@! vsp (:$ (- arm::node-size)))))   
3510  ((:pred >= min 2)
3511   (str arg_y (:@! vsp (:$ (- arm::node-size)))))
3512  ((:pred >= min 1)
3513   (mov arg_x arg_z))
3514  (mov arg_y (:$ arm::nil-value))
3515  (b :last)
3516  :one
3517  ;; We got min+1 args: arg_y was supplied, arg_z defaults to nil.
3518  ((:pred >= min 2)
3519   (str arg_x (:@! vsp (:$ (- arm::node-size)))))
3520  ((:pred >= min 1)
3521   (mov arg_x arg_y))
3522  (mov arm::arg_y arm::arg_z)
3523  :last
3524  (mov arg_z (:$ arm::nil-value))
3525  :done)
3526
3527(define-arm-vinsn default-3-args (()
3528                                  ((min :u16const)))
3529  (cmp nargs (:$ (:apply ash min 2)))
3530  (beq :none)
3531  (cmp nargs (:$ (:apply ash (:apply + 2 min) 2)))
3532
3533  (bgt :done)
3534  (beq :two)
3535  ;; The first (of three) &optional args was supplied.
3536  ((:pred >= min 2)
3537   (str arg_x (:@! vsp (:$ (- arm::node-size)))))
3538  ((:pred >= min 1)
3539   (str arg_y (:@! vsp (:$ (- arm::node-size)))))
3540  (mov arg_x arg_z)
3541  (b :last-2)
3542  :two
3543  ;; The first two (of three) &optional args were supplied.
3544  ((:pred >= min 1)
3545   (str arg_x (:@! vsp (:$ (- arm::node-size)))))
3546  (mov arg_x arg_y)
3547  (mov arg_y arg_z)
3548  (b :last-1)
3549  ;; None of the three &optional args was provided.
3550  :none
3551  ((:pred >= min 3)
3552   (str arg_x (:@! vsp (:$ (- arm::node-size)))))
3553  ((:pred >= min 2)
3554   (str arg_y (:@! vsp (:$ (- arm::node-size)))))
3555  ((:pred >= min 1)
3556   (str arg_z (:@! vsp (:$ (- arm::node-size)))))
3557  (mov arg_x (:$ arm::nil-value))
3558  :last-2
3559  (mov arg_y (:$ arm::nil-value))
3560  :last-1
3561  (mov arg_z (:$ arm::nil-value))
3562  :done)
3563
3564
3565
3566;;; "n" is the sum of the number of required args +
3567;;; the number of &optionals. 
3568(define-arm-vinsn (default-optionals :call :subprim-call) (()
3569                                                           ((n :u16const)))
3570  (mov imm0 (:$ (:apply ash n 2)))
3571  (sploadlr .SPdefault-optional-args)
3572  (blx lr))
3573
3574;;; fname contains a known symbol
3575(define-arm-vinsn (call-known-symbol :call) (((result (:lisp arm::arg_z)))
3576                                             ())
3577  (ldr nfn (:@ fname (:$ arm::symbol.fcell)))
3578  (ldr lr (:@ nfn (:$ arm::function.entrypoint)))
3579  (blx lr))
3580
3581(define-arm-vinsn (jump-known-symbol :jumplr) (()
3582                                               ())
3583  (ldr nfn (:@ fname (:$ arm::symbol.fcell)))
3584  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
3585
3586(define-arm-vinsn (call-known-function :call) (()
3587                                               ())
3588  (ldr lr (:@ nfn (:$ arm::function.entrypoint)))
3589  (blx lr))
3590
3591(define-arm-vinsn (jump-known-function :jumplr) (()
3592                                                 ())
3593  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
3594
3595(define-arm-vinsn (%schar8 :predicatable)
3596    (((char :imm))
3597     ((str :lisp)
3598      (idx :imm))
3599     ((imm :u32)))
3600  (mov imm (:lsr idx (:$ arm::fixnumshift)))
3601  (add imm imm (:$ arm::misc-data-offset))
3602  (ldrb imm (:@ str imm))
3603  (mov imm (:lsl imm (:$ arm::charcode-shift)))
3604  (orr char imm (:$ arm::subtag-character)))
3605
3606(define-arm-vinsn (%schar32 :predicatable)
3607    (((char :imm))
3608     ((str :lisp)
3609      (idx :imm))
3610     ((imm :u32)))
3611  (add imm idx (:$ arm::misc-data-offset))
3612  (ldr imm (:@ str imm))
3613  (mov imm (:lsl imm (:$ arm::charcode-shift)))
3614  (orr char imm (:$ arm::subtag-character)))
3615
3616
3617(define-arm-vinsn (%set-schar8 :predicatable)
3618    (()
3619     ((str :lisp)
3620      (idx :imm)
3621      (char :imm))
3622     ((imm :u32)
3623      (imm1 :u32)))
3624  (mov imm (:lsr idx (:$ arm::fixnumshift)))
3625  (add imm imm (:$ arm::misc-data-offset))
3626  (mov imm1 (:lsr char (:$ arm::charcode-shift)))
3627  (strb imm1 (:@ str imm)))
3628
3629(define-arm-vinsn (%set-schar32 :predicatable)
3630    (()
3631     ((str :lisp)
3632      (idx :imm)
3633      (char :imm))
3634     ((imm :u32)
3635      (imm1 :u32)))
3636  (add imm idx (:$ arm::misc-data-offset))
3637  (mov imm1 (:lsr char (:$ arm::charcode-shift)))
3638  (str imm1 (:@ str imm)))
3639
3640(define-arm-vinsn (%set-scharcode8 :predicatable)
3641    (()
3642     ((str :lisp)
3643      (idx :imm)
3644      (code :imm))
3645     ((imm :u32)
3646      (imm1 :u32)))
3647  (mov imm (:lsr idx (:$ arm::fixnumshift)))
3648  (add imm imm (:$ arm::misc-data-offset))
3649  (mov imm1 (:lsr code (:$ arm::fixnumshift)))
3650  (strb imm1 (:@ str imm)))
3651
3652
3653(define-arm-vinsn (%set-scharcode32 :predicatable)
3654    (()
3655     ((str :lisp)
3656      (idx :imm)
3657      (code :imm))
3658     ((imm :u32)
3659      (imm1 :u32)))
3660  (add imm idx (:$ arm::misc-data-offset))
3661  (mov imm1 (:lsr code (:$ arm::fixnumshift)))
3662  (str imm1 (:@ str imm)))
3663
3664(define-arm-vinsn (%scharcode8 :predicatable)
3665    (((code :imm))
3666     ((str :lisp)
3667      (idx :imm))
3668     ((imm :u32)))
3669  (mov imm (:lsr idx (:$ arm::fixnumshift)))
3670  (add imm imm (:$ arm::misc-data-offset))
3671  (ldrb imm (:@ str imm))
3672  (mov code (:lsl imm (:$ arm::fixnumshift))))
3673
3674(define-arm-vinsn (%scharcode32 :predicatable)
3675    (((code :imm))
3676     ((str :lisp)
3677      (idx :imm))
3678     ((imm :u32)))
3679  (add imm idx (:$ arm::misc-data-offset))
3680  (ldr imm (:@ str imm))
3681  (mov code (:lsl imm (:$ arm::fixnumshift))))
3682
3683;;; Clobbers LR
3684(define-arm-vinsn %debug-trap (()
3685                               ())
3686  (uuo-debug-trap))
3687
3688
3689(define-arm-vinsn eep.address (((dest t))
3690                               ((src (:lisp (:ne dest )))))
3691  (ldr dest (:@ src (:$ (+ (ash 1 2) arm::misc-data-offset))))
3692  (cmp dest (:$ arm::nil-value))
3693  (bne :ok)
3694  (uuo-eep-unresolved  dest src)
3695  :ok)
3696                 
3697(define-arm-vinsn (%natural+ :predicatable)
3698    (((dest :u32))
3699     ((x :u32) (y :u32)))
3700  (add dest x y))
3701
3702(define-arm-vinsn (%natural+-c :predicatable)
3703    (((dest :u32))
3704     ((x :u32) (y :u16const)))
3705  (add dest x (:$ y)))
3706
3707(define-arm-vinsn (%natural- :predicatable)
3708    (((dest :u32))
3709     ((x :u32) (y :u32)))
3710  (sub dest x y))
3711
3712(define-arm-vinsn (%natural--c :predicatable)
3713    (((dest :u32))
3714     ((x :u32) (y :u16const)))
3715  (sub dest x (:$ y)))
3716
3717(define-arm-vinsn (%natural-logior :predicatable)
3718    (((dest :u32))
3719     ((x :u32) (y :u32)))
3720  (orr dest x y))
3721
3722(define-arm-vinsn (%natural-logior-c :predicatable)
3723    (((dest :u32))
3724     ((x :u32) (c :u32const)))
3725  (orr dest x (:$ c)))
3726
3727(define-arm-vinsn (%natural-logxor :predicatable)
3728    (((dest :u32))
3729     ((x :u32) (y :u32)))
3730  (eor dest x y))
3731
3732(define-arm-vinsn (%natural-logxor-c :predicatable)
3733    (((dest :u32))
3734     ((x :u32) (c :u32const)))
3735  (eor dest x (:$ c)))
3736
3737(define-arm-vinsn (%natural-logand :predicatable)
3738    (((dest :u32))
3739     ((x :u32) (y :u32)))
3740  (and dest x y))
3741
3742(define-arm-vinsn %natural-logand-c (((dest :u32))
3743                                          ((x :u32) (c :u16const))
3744                                     )
3745  (and dest x (:$ c)))
3746
3747(define-arm-vinsn %ilogbitp-constant-bit (((dest :crf))
3748                                          ((fixnum :imm)
3749                                           (bitnum :u8const)))
3750  (tst fixnum (:$ (:apply ash 1 (:apply + bitnum arm::fixnumshift)))))
3751
3752(define-arm-vinsn %ilogbitp-variable-bit (((dest :crf))
3753                                          ((fixnum :imm)
3754                                           (bitnum :u8))
3755                                          ((mask :imm)
3756                                           (unboxed :u8)))
3757  (mov unboxed (:asr bitnum (:$ arm::fixnumshift)))
3758  (mov mask (:$ arm::fixnumone))
3759  (tst fixnum (:lsl mask unboxed)))
3760
3761
3762
3763
3764
3765(define-arm-vinsn (disable-interrupts :predicatable)
3766    (((dest :lisp))
3767     ()
3768     ((temp :imm)
3769      (temp2 :imm)))
3770  (ldr temp2 (:@ rcontext (:$ arm::tcr.tlb-pointer)))
3771  (mov temp (:$ -4))
3772  (ldr dest (:@ temp2 (:$ arm::interrupt-level-binding-index)))
3773  (str temp (:@ temp2 (:$ arm::interrupt-level-binding-index))))
3774
3775(define-arm-vinsn (load-character-constant :predicatable)
3776    (((dest :lisp))
3777     ((code :u32const)))
3778  (movw dest (:$ (:apply logior (:apply ash (:apply logand code #xff) arm::charcode-shift) arm::subtag-character)))
3779  ((:pred > code 256)
3780   (movt dest (:$ (:apply ash code -8)))))
3781
3782
3783(define-arm-vinsn %symbol->symptr (((dest :lisp))
3784                                   ((src :lisp))
3785                                   ((tag :u8)))
3786  (cmp src (:$ arm::nil-value))
3787  (and tag src (:$ arm::tagmask))
3788  (beq :nilsym)
3789  (cmp tag (:$ arm::tag-misc))
3790  (ldrbeq tag (:@ src (:$ arm::misc-subtag-offset)))
3791  (cmp tag (:$ arm::subtag-symbol))
3792  (beq :symbol)
3793  (uuo-error-reg-not-xtype src (:$ arm::subtag-symbol))
3794  :symbol
3795  ((:not (:pred =
3796                (:apply %hard-regspec-value dest)
3797                (:apply %hard-regspec-value src)))
3798   (mov dest src))
3799  (b :done)
3800  :nilsym
3801  (add dest src (:$ arm::nilsym-offset))
3802  :done)
3803
3804;;; Subprim calls.  Done this way for the benefit of VINSN-OPTIMIZE.
3805(defmacro define-arm-subprim-call-vinsn ((name &rest other-attrs) spno)
3806  `(define-arm-vinsn (,name :call :subprim-call ,@other-attrs) (() ())
3807    (sploadlr ,spno)
3808    (blx lr)))
3809
3810(defmacro define-arm-subprim-jump-vinsn ((name &rest other-attrs) spno &optional)
3811  `(define-arm-vinsn (,name  :jumpLR ,@other-attrs) (() ())
3812    (spjump ,spno)))
3813
3814
3815(define-arm-subprim-call-vinsn (save-values) .SPsave-values)
3816
3817(define-arm-subprim-call-vinsn (recover-values)  .SPrecover-values)
3818
3819(define-arm-subprim-call-vinsn (add-values) .SPadd-values)
3820
3821
3822(define-arm-subprim-call-vinsn (pass-multiple-values)  .SPmvpass)
3823
3824(define-arm-subprim-call-vinsn (pass-multiple-values-symbol) .SPmvpasssym)
3825
3826(define-arm-subprim-jump-vinsn (jump-known-symbol-ool) .SPjmpsym)
3827
3828(define-arm-subprim-call-vinsn (call-known-symbol-ool)  .SPjmpsym)
3829
3830
3831(define-arm-subprim-jump-vinsn (tail-call-sym-gen) .SPtcallsymgen)
3832
3833(define-arm-subprim-jump-vinsn (tail-call-fn-gen) .SPtcallnfngen)
3834
3835(define-arm-subprim-jump-vinsn (tail-call-sym-slide) .SPtcallsymslide)
3836
3837(define-arm-subprim-jump-vinsn (tail-call-fn-slide) .SPtcallnfnslide)
3838
3839
3840(define-arm-subprim-call-vinsn (funcall)  .SPfuncall)
3841
3842(define-arm-subprim-jump-vinsn (tail-funcall-gen) .SPtfuncallgen)
3843
3844(define-arm-subprim-jump-vinsn (tail-funcall-slide) .SPtfuncallslide)
3845
3846(define-arm-vinsn (tail-funcall-vsp :jumpLR :predicatable) (() ())
3847  (ldmia (:! sp) (imm0 vsp fn lr))
3848  (spjump .SPfuncall))
3849
3850(define-arm-subprim-call-vinsn (spread-lexpr)  .SPspread-lexprz)
3851
3852(define-arm-subprim-call-vinsn (spread-list)  .SPspreadargz)
3853
3854
3855(define-arm-subprim-call-vinsn (getu32) .SPgetu32)
3856
3857(define-arm-subprim-call-vinsn (gets32) .SPgets32)
3858
3859
3860(define-arm-subprim-call-vinsn (stack-cons-list)  .SPstkconslist)
3861
3862(define-arm-subprim-call-vinsn (list) .SPconslist)
3863
3864(define-arm-subprim-call-vinsn (stack-cons-list*)  .SPstkconslist-star)
3865
3866(define-arm-subprim-call-vinsn (list*) .SPconslist-star)
3867
3868(define-arm-subprim-call-vinsn (make-stack-block)  .SPmakestackblock)
3869
3870(define-arm-subprim-call-vinsn (make-stack-block0)  .Spmakestackblock0)
3871
3872(define-arm-subprim-call-vinsn (make-stack-list)  .Spmakestacklist)
3873
3874(define-arm-subprim-call-vinsn (make-stack-vector)  .SPmkstackv)
3875
3876(define-arm-subprim-call-vinsn (make-stack-gvector)  .SPstkgvector)
3877(define-arm-vinsn (make-stack-closure :call :subprim-call) (() ())
3878  (sploadlr .SPstkgvector)
3879  (blx lr)
3880  (ldr lr (:@ arg_z (:$ arm::function.codevector)))
3881  (add lr lr (:$ arm::misc-data-offset))
3882  (str lr (:@ arg_z (:$ arm::function.entrypoint))))
3883                 
3884
3885(define-arm-subprim-call-vinsn (stack-misc-alloc)  .SPstack-misc-alloc)
3886
3887(define-arm-subprim-call-vinsn (stack-misc-alloc-init)  .SPstack-misc-alloc-init)
3888
3889(define-arm-subprim-call-vinsn (bind-nil)  .SPbind-nil)
3890
3891(define-arm-subprim-call-vinsn (bind-self)  .SPbind-self)
3892
3893(define-arm-subprim-call-vinsn (bind-self-boundp-check)  .SPbind-self-boundp-check)
3894
3895(define-arm-subprim-call-vinsn (bind)  .SPbind)
3896
3897(define-arm-subprim-jump-vinsn (nvalret :jumpLR) .SPnvalret)
3898
3899(define-arm-subprim-call-vinsn (nthrowvalues) .SPnthrowvalues)
3900
3901(define-arm-subprim-call-vinsn (nthrow1value) .SPnthrow1value)
3902
3903(define-arm-subprim-call-vinsn (slide-values) .SPmvslide)
3904
3905
3906(define-arm-subprim-call-vinsn (debind) .SPdebind)
3907
3908
3909(define-arm-subprim-call-vinsn (keyword-bind) .SPkeyword-bind)
3910
3911(define-arm-subprim-call-vinsn (stack-rest-arg) .SPstack-rest-arg)
3912
3913(define-arm-subprim-call-vinsn (req-stack-rest-arg) .SPreq-stack-rest-arg)
3914
3915(define-arm-subprim-call-vinsn (stack-cons-rest-arg) .SPstack-cons-rest-arg)
3916
3917(define-arm-subprim-call-vinsn (heap-rest-arg) .SPheap-rest-arg)
3918
3919(define-arm-subprim-call-vinsn (req-heap-rest-arg) .SPreq-heap-rest-arg)
3920
3921(define-arm-subprim-call-vinsn (heap-cons-rest-arg) .SPheap-cons-rest-arg)
3922
3923(define-arm-subprim-call-vinsn (opt-supplied-p) .SPopt-supplied-p)
3924
3925(define-arm-subprim-call-vinsn (gvector) .SPgvector)
3926
3927(define-arm-subprim-call-vinsn (discard-temp-frame) .SPdiscard_stack_object)
3928
3929(define-arm-vinsn (nth-value :call :subprim-call) (((result :lisp))
3930                                                   ())
3931  (sploadlr .SPnthvalue)
3932  (blx lr))
3933
3934(define-arm-subprim-call-vinsn (fitvals) .SPfitvals)
3935
3936(define-arm-subprim-call-vinsn (misc-alloc) .SPmisc-alloc)
3937
3938(define-arm-subprim-call-vinsn (misc-alloc-init) .SPmisc-alloc-init)
3939
3940(define-arm-subprim-call-vinsn (integer-sign) .SPinteger-sign)
3941
3942;;; Even though it's implemented by calling a subprim, THROW is really
3943;;; a JUMP (to a possibly unknown destination).  If the destination's
3944;;; really known, it should probably be inlined (stack-cleanup, value
3945;;; transfer & jump ...)
3946(define-arm-vinsn (throw :jump-unknown) (()
3947                                         ())
3948  (sploadlr .SPthrow)
3949  (blx lr))
3950
3951(define-arm-subprim-call-vinsn (mkcatchmv) .SPmkcatchmv)
3952
3953(define-arm-subprim-call-vinsn (mkcatch1v) .SPmkcatch1v)
3954
3955(define-arm-subprim-call-vinsn (setqsym) .SPsetqsym)
3956
3957(define-arm-subprim-call-vinsn (ksignalerr) .SPksignalerr)
3958
3959(define-arm-subprim-call-vinsn (subtag-misc-ref) .SPsubtag-misc-ref)
3960
3961(define-arm-subprim-call-vinsn (subtag-misc-set) .SPsubtag-misc-set)
3962
3963(define-arm-subprim-call-vinsn (mkunwind) .SPmkunwind)
3964(define-arm-subprim-call-vinsn (nmkunwind) .SPmkunwind)
3965
3966
3967(define-arm-subprim-call-vinsn (progvsave) .SPprogvsave)
3968
3969(define-arm-subprim-jump-vinsn (progvrestore) .SPprogvrestore)
3970
3971
3972(define-arm-subprim-call-vinsn (misc-ref) .SPmisc-ref)
3973
3974(define-arm-subprim-call-vinsn (misc-set) .SPmisc-set)
3975
3976(define-arm-subprim-call-vinsn (gets64) .SPgets64)
3977
3978(define-arm-subprim-call-vinsn (getu64) .SPgetu64)
3979
3980(define-arm-subprim-call-vinsn (makeu64) .SPmakeu64)
3981
3982(define-arm-subprim-call-vinsn (makes64) .SPmakes64)
3983
3984
3985
3986
3987
3988
3989
3990(define-arm-subprim-call-vinsn (bind-interrupt-level-0) .SPbind-interrupt-level-0)
3991
3992
3993(define-arm-vinsn bind-interrupt-level-0-inline (()
3994                                                 ()
3995                                                 ((tlb :imm)
3996                                                  (value :imm)
3997                                                  (link :imm)
3998                                                  (temp :imm)))
3999  (ldr tlb (:@ rcontext (:$ arm::tcr.tlb-pointer)))
4000  (ldr value (:@ tlb (:$ arm::interrupt-level-binding-index)))
4001  (ldr link (:@ rcontext (:$ arm::tcr.db-link)))
4002  (cmp value (:$ 0))
4003  (mov temp (:$ arm::interrupt-level-binding-index))
4004  (str value (:@! vsp (:$ -4)))
4005  (str temp (:@! vsp (:$ -4)))
4006  (str link (:@! vsp (:$ -4)))
4007  (mov temp (:$ 0))
4008  (str temp (:@ tlb (:$ arm::interrupt-level-binding-index)))
4009  (str vsp  (:@ rcontext (:$ arm::tcr.db-link)))
4010  (bge :done)
4011  (ldr nargs (:@ rcontext (:$ arm::tcr.interrupt-pending)))
4012  (cmp nargs (:$ 0))
4013  (beq :done)
4014  (uuo-interrupt-now)
4015  :done)
4016                                                   
4017 
4018                                                   
4019(define-arm-subprim-call-vinsn (bind-interrupt-level-m1) .SPbind-interrupt-level-m1)
4020
4021(define-arm-vinsn bind-interrupt-level-m1-inline (()
4022                                                  ()
4023                                                  ((tlb :imm)
4024                                                   (oldvalue :imm)
4025                                                   (link :imm)
4026                                                   (newvalue :imm)
4027                                                   (idx :imm)))
4028  (mov newvalue (:$ (ash -1 arm::fixnumshift)))
4029  (mov idx (:$ arm::interrupt-level-binding-index))
4030  (ldr tlb (:@ rcontext (:$ arm::tcr.tlb-pointer)))
4031  (ldr oldvalue (:@ tlb (:$ arm::interrupt-level-binding-index)))
4032  (ldr link (:@ rcontext (:$ arm::tcr.db-link)))
4033  (str oldvalue (:@! vsp (:$ (- arm::node-size))))
4034  (str idx (:@! vsp (:$ (- arm::node-size))))
4035  (str link (:@! vsp (:$ (- arm::node-size))))
4036  (str newvalue (:@ tlb (:$ arm::interrupt-level-binding-index)))
4037  (str vsp  (:@ rcontext (:$ arm::tcr.db-link))))
4038
4039(define-arm-subprim-call-vinsn (bind-interrupt-level) .SPbind-interrupt-level)
4040
4041(define-arm-subprim-call-vinsn (unbind-interrupt-level) .SPunbind-interrupt-level)
4042
4043(define-arm-subprim-call-vinsn (eabi-ff-call) .SPeabi-ff-call)
4044
4045(define-arm-vinsn unbind-interrupt-level-inline (()
4046                                                 ()
4047                                                 ((preserve (:lisp #.arm::arg_z))
4048                                                  (preserved (:u32 #.arm::nargs))
4049                                                  (tlb :imm)
4050                                                  (link :imm)
4051                                                  (saved-value :imm)
4052                                                  (restored-value :imm)))
4053  (ldr tlb (:@ rcontext (:$ arm::tcr.tlb-pointer)))
4054  (ldr saved-value (:@ tlb (:$ arm::interrupt-level-binding-index)))
4055  (ldr link (:@ rcontext (:$ arm::tcr.db-link)))
4056  (ldr restored-value (:@ link (:$ 8)))
4057  (ldr link (:@ link (:$ 0)))
4058  (cmp restored-value (:$ 0))
4059  (str restored-value (:@ tlb (:$ arm::interrupt-level-binding-index)))
4060  (str link (:@ rcontext (:$ arm::tcr.db-link)))
4061  (blt :done)
4062  (cmp saved-value (:$ 0))
4063  (bge :done)
4064  (ldr link (:@ rcontext (:$ arm::tcr.interrupt-pending)))
4065  (cmp link (:$ 0))
4066  (beq :done)
4067  (uuo-interrupt-now)
4068  :done)
4069
4070(define-arm-vinsn test-fixnum  (((dest :crf))
4071                                ((src :lisp)))
4072  (tst src (:$ arm::fixnummask)))
4073                 
4074 
4075
4076
4077(define-arm-vinsn branch-unless-arg-fixnum (()
4078                                            ((arg :lisp)
4079                                             (lab :label))
4080                                            ())
4081  (tst arg (:$ arm::fixnummask))
4082  (bne lab))
4083
4084
4085
4086
4087(define-arm-vinsn branch-unless-both-args-fixnums (()
4088                                                   ((arg0 :lisp)
4089                                                    (arg1 :lisp)
4090                                                    (lab :label))
4091                                                   ((tag :u8)))
4092  (orr tag arg0 arg1)
4093  (tst tag (:$ arm::fixnummask))
4094  (bne lab))
4095
4096(define-arm-vinsn %ilognot (((dest :imm))
4097                            ((src :imm))
4098                            ((temp :u32)))
4099  (orr temp src (:$ arm::fixnummask))
4100  (mvn dest temp))
4101
4102(define-arm-vinsn fixnum-ref-c-double-float (((dest :double-float))
4103                                             ((base :imm)
4104                                              (idx :u32const)))
4105  (fldd dest (:@ base (:$ (:apply ash idx 3)))))
4106
4107(define-arm-vinsn fixnum-ref-double-float (((dest :double-float))
4108                                           ((base :imm)
4109                                            (idx :imm))
4110                                           ((temp :imm)))
4111  (add temp base (:lsl idx (:$ 1)))
4112  (fldd dest (:@ temp (:$ 0))))
4113
4114(define-arm-vinsn fixnum-set-c-double-float (()
4115                                             ((base :imm)
4116                                              (idx :u32const)
4117                                              (val :double-float)))
4118  (fstd val (:@ base (:$ (:apply ash idx 3)))))
4119
4120
4121(define-arm-vinsn fixnum-set-double-float (()
4122                                           ((base :imm)
4123                                            (idx :imm)
4124                                            (val :double-float))
4125                                           ((temp :imm)))
4126  (add temp base (:lsl idx (:$ 1)))
4127  (fstd val (:@ temp (:$ 0))))
4128                                             
4129
4130;;; In case arm::*arm-opcodes* was changed since this file was compiled.
4131#+maybe-never
4132(queue-fixup
4133 (fixup-vinsn-templates *arm-vinsn-templates* arm::*arm-opcode-numbers*))
4134
4135(provide "ARM-VINSNS")
4136
Note: See TracBrowser for help on using the repository browser.