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

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

Define another 3-register-argument UUO ('uuo_error_array_axis_bounds');
use it to report array bounds errors for multidimensional array access
(incorporating the axis/dimension in the UUO and therefore the error
message.)

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