source: release/1.6/source/compiler/ARM/arm-vinsns.lisp @ 14485

Last change on this file since 14485 was 14485, checked in by rme, 9 years ago

Merge ARM FFI fixes from trunk.

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