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

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

!ALLOC-EABI-C-FRAME: can save a few instructions, since the size
of the frame is a constant.

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