source: branches/arm/compiler/ARM/arm-vinsns.lisp @ 14098

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

Fix braino in UNBOX-S8; new subprim call/jump scheme.

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