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

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

REQUIRE-S8 was shifting in the right direction (for once), but
by the wrong amount.

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