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

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

arm-misc.lisp: Need xchgl for ARM (used in futex-based locking.)
l0-misc.lisp: ROOM and aux functions: no tsp on ARM
vinsn.lisp: rename :conditional attribute to :predicatable.
arm-vinsns.lisp, arm2.lisp: replace COPY-FPR with all 4 single/double
variants. Use :predicatable attribute to avoid some conditional branches.
arm-asm.lisp, arm-disassemble.lisp: add, fix some instruction definitions.

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