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

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

Keep moving forward. Can -almost- compile simple functions.

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