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

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

Some stuff compiles; still a lot of work to do.
Try to reduce stack traffic in some simple cases by tracking which
registers contain copies of which stack locations. Should try to
exploit this further (and port to other platforms when it's working
reliably.)
Todo: well, a very long list of things, but one that seems obvious
is to try to use predication (at the vinsn level) to reduce the number
of conditional branches.

File size: 123.2 KB
RevLine 
[13713]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                                          ())
[13741]50  (mov  dest (:lsr idx (:$ 1)))
[13713]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                                         ())
[13741]57  (mov dest (:lsr idx (:$ 2)))
[13713]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
[13741]67#+notyet
[13713]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))
[13741]138                                          ((temp :u32)))
139  (ldr temp (:@ v scaled-idx))
140  (fmsr dest temp))
[13713]141
142(define-arm-vinsn misc-ref-c-single-float  (((dest :single-float))
143                                            ((v :lisp)
144                                             (idx :u32const))
[13741]145                                            ((temp :u32)))
146  (ldr temp (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2)))))
147  (fmsr dest temp))
[13713]148
149(define-arm-vinsn misc-ref-double-float  (((dest :double-float))
150                                          ((v :lisp)
151                                           (scaled-idx :u32))
[13741]152                                          ((low (:u32 #.arm::imm0))
153                                           (high (:u32 #.arm::imm1))))
154  (ldrd low (:@ v scaled-idx))
155  (fmdrr dest low high))
[13713]156
157
158(define-arm-vinsn misc-ref-c-double-float  (((dest :double-float))
159                                            ((v :lisp)
160                                             (idx :u32const))
[13741]161                                            ((low (:u32 #.arm::imm0))
162                                             (high (:u32 #.arm::imm1))))
163  (ldrd low (:@ v (:$ idx)))
164  (fmdrr dest low high))
[13713]165
166(define-arm-vinsn misc-set-c-double-float (((val :double-float))
167                                           ((v :lisp)
[13741]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))))))
[13713]173
174(define-arm-vinsn misc-set-double-float (()
175                                         ((val :double-float)
176                                          (v :lisp)
[13741]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)))
[13713]182
[13741]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))))))
[13713]190
191
192
193(define-arm-vinsn misc-set-single-float (()
194                                         ((val :single-float)
195                                          (v :lisp)
[13741]196                                          (scaled-idx :u32))
197                                         ((temp :u32)))
198  (fmrs temp val)
199  (str temp (:@ v scaled-idx)))
[13713]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                                   ())
[13741]218  (strh val (:+@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1))))))
[13713]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                                 ())
[13741]229  (ldrsh dest (:@ v scaled-idx)))
[13713]230
231(define-arm-vinsn misc-ref-c-s16  (((dest :s16))
232                                   ((v :lisp)
233                                    (idx :u32const))
234                                   ())
[13741]235  (ldrsh dest (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1))))))
[13713]236
237
238(define-arm-vinsn misc-set-c-s16  (((val :s16))
239                                   ((v :lisp)
240                                    (idx :u32const))
241                                   ())
[13741]242  (strh val (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1))))))
[13713]243
244(define-arm-vinsn misc-set-s16 (((val :s16))
245                                ((v :lisp)
246                                 (scaled-idx :s32)))
[13741]247  (strh val (:@ v scaled-idx)))
[13713]248
249(define-arm-vinsn misc-ref-u8  (((dest :u8))
250                                ((v :lisp)
251                                 (scaled-idx :u32))
252                                ())
[13741]253  (ldrb dest (:@ v scaled-idx)))
[13713]254
255(define-arm-vinsn misc-ref-c-u8  (((dest :u8))
256                                  ((v :lisp)
257                                   (idx :u32const))
258                                  ())
[13741]259  (ldrb dest (:@ v (:$ (:apply + arm::misc-data-offset idx)))))
[13713]260
261(define-arm-vinsn misc-set-c-u8  (((val :u8))
262                                  ((v :lisp)
263                                   (idx :u32const))
264                                  ())
[13741]265  (strb val (:@ v (:$ (:apply + arm::misc-data-offset idx)))))
[13713]266
267(define-arm-vinsn misc-set-u8  (((val :u8))
268                                ((v :lisp)
269                                 (scaled-idx :u32))
270                                ())
[13741]271  (strb val (:@ v scaled-idx)))
[13713]272
273(define-arm-vinsn misc-ref-s8  (((dest :s8))
274                                ((v :lisp)
275                                 (scaled-idx :u32))
276                                ())
[13741]277  (ldrsb dest (:@ v scaled-idx)))
[13713]278
279(define-arm-vinsn misc-ref-c-s8  (((dest :s8))
280                                  ((v :lisp)
281                                   (idx :u32const))
282                                  ())
[13741]283  (ldrsb dest (:@ v (:$ (:apply + arm::misc-data-offset idx)))))
[13713]284
285(define-arm-vinsn misc-set-c-s8  (((val :s8))
286                                  ((v :lisp)
287                                   (idx :u32const))
288                                  ())
[13741]289  (strb val (:@ v (:$ (:apply + arm::misc-data-offset idx)))))
[13713]290
291(define-arm-vinsn misc-set-s8  (((val :s8))
292                                ((v :lisp)
293                                 (scaled-idx :u32))
294                                ())
[13741]295  (strb val (:@ v scaled-idx)))
[13713]296
[13741]297#+notyet
[13713]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
[13741]305#+notyet
[13713]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                                  ())
[13741]322  (ldr dest (:@ v scaled-idx)))
[13713]323
324
325
326
327(define-arm-vinsn misc-ref-c-node (((dest :lisp))
328                                   ((v :lisp)
329                                    (idx :s16const))
330                                   ())
[13741]331  (ldr dest (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))))
[13713]332
333(define-arm-vinsn misc-set-node (()
334                                 ((val :lisp)
335                                  (v :lisp)
336                                  (scaled-idx :u32)))
[13741]337  (str val (:@ v scaled-idx)))
[13713]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                                   ())
[13741]346  (str val (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))))
[13713]347
348
349(define-arm-vinsn misc-element-count-fixnum (((dest :imm))
350                                             ((v :lisp))
351                                             ((temp :u32)))
[13741]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)))))
[13713]355
356(define-arm-vinsn check-misc-bound (()
357                                    ((idx :imm)
358                                     (v :lisp))
359                                    ((temp :u32)))
[13741]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))
[13713]364
365(define-arm-vinsn 2d-unscaled-index (((dest :imm)
366                                      (dim1 :u32))
367                                     ((dim1 :u32)
368                                      (i :imm)
369                                      (j :imm)))
[13741]370  (mul dim1 i dim1)
[13713]371  (add dest dim1 j))
372
373;; dest <- (+ (* i dim1 dim2) (* j dim2) k)
[13741]374
[13713]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)))
[13741]383  (mul dim1 dim1 dim2)
384  (mul dim2 j dim2)
385  (mul dim1 i dim1)
[13713]386  (add dim2 dim1 dim2)
387  (add dest dim2 k))
388
389
390(define-arm-vinsn 2d-dim1 (((dest :u32))
391                           ((header :lisp)))
[13741]392  (ldr dest (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))))))
393  (mov dest (:asr dest (:$ arm::fixnumshift))))
[13713]394
[13741]395
396
[13713]397(define-arm-vinsn 3d-dims (((dim1 :u32)
398                            (dim2 :u32))
399                           ((header :lisp)))
[13741]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))))
[13713]404
405;; Return dim1 (unboxed)
406(define-arm-vinsn check-2d-bound (((dim :u32))
407                                  ((i :imm)
408                                   (j :imm)
409                                   (header :lisp)))
[13741]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))))
[13713]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)))
[13741]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))))
[13713]435
436(define-arm-vinsn array-data-vector-ref (((dest :lisp))
437                                         ((header :lisp)))
[13741]438  (ldr dest (:@ header (:$ arm::arrayH.data-vector))))
[13713]439 
440
[13741]441#+can-encode-array-rank-trap
[13713]442(define-arm-vinsn check-arrayH-rank (()
443                                     ((header :lisp)
444                                      (expected :u32const))
445                                     ((rank :imm)))
[13741]446  (ldr rank (:@ header (:$ arm::arrayH.rank)))
447  (cmp rank (:apply ash expected arm::fixnumshift))
448  (uuo-error-bad-array-rank (:? ne) expected header))
[13713]449
[13741]450#+can-remember-what-this-means
[13713]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)))
[13741]468  (ldr dest (:@ node (:$ (:apply + arm::misc-data-offset (:apply ash cellno 2))))))
[13713]469
470
471
472(define-arm-vinsn  %slot-ref (((dest :lisp))
473                              ((instance (:lisp (:ne dest)))
474                               (index :lisp))
475                              ((scaled :u32)))
[13741]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))
[13713]480
481
482;;; Untagged memory reference & assignment.
483
484(define-arm-vinsn mem-ref-c-fullword (((dest :u32))
485                                      ((src :address)
486                                       (index :s16const)))
[13741]487  (ldr dest (:@ src (:$ index))))
[13713]488
489
490(define-arm-vinsn mem-ref-c-signed-fullword (((dest :s32))
491                                             ((src :address)
492                                              (index :s16const)))
[13741]493  (ldr dest (:@ src (:$ index))))
[13713]494
495(define-arm-vinsn mem-ref-c-natural (((dest :u32))
496                                     ((src :address)
497                                      (index :s16const)))
[13741]498  (ldr dest (:@ src (:$ index))))
[13713]499 
500
501(define-arm-vinsn mem-ref-fullword (((dest :u32))
502                                    ((src :address)
503                                     (index :s32)))
[13741]504  (ldr dest (:@ src index)))
[13713]505
506(define-arm-vinsn mem-ref-signed-fullword (((dest :u32))
507                                           ((src :address)
508                                            (index :s32)))
[13741]509  (ldr dest (:@ src index)))
[13713]510
511(define-arm-vinsn mem-ref-natural (((dest :u32))
512                                   ((src :address)
513                                    (index :s32)))
[13741]514  (ldr dest (:@ src index)))
[13713]515
516
517(define-arm-vinsn mem-ref-c-u16 (((dest :u16))
518                                 ((src :address)
519                                  (index :s16const)))
[13741]520  (ldrh dest (:@ src (:$ index))))
[13713]521
522
523(define-arm-vinsn mem-ref-u16 (((dest :u16))
524                               ((src :address)
525                                (index :s32)))
[13741]526  (ldrh dest (:@ src index)))
[13713]527
528
529
530(define-arm-vinsn mem-ref-c-s16 (((dest :s16))
531                                 ((src :address)
532                                  (index :s16const)))
[13741]533  (ldrsh dest (:@ src (:$ index))))
[13713]534
535(define-arm-vinsn mem-ref-s16 (((dest :s16))
536                               ((src :address)
537                                (index :s32)))
[13741]538  (ldrsh dest (:@ src index)))
[13713]539
540(define-arm-vinsn mem-ref-c-u8 (((dest :u8))
541                                ((src :address)
542                                 (index :s16const)))
[13741]543  (ldrb dest (:@ src (:$ index))))
[13713]544
545(define-arm-vinsn mem-ref-u8 (((dest :u8))
546                              ((src :address)
547                               (index :s32)))
[13741]548  (ldrb dest (:@ src index)))
[13713]549
550(define-arm-vinsn mem-ref-c-s8 (((dest :s8))
551                                ((src :address)
552                                 (index :s16const)))
[13741]553  (ldrsb dest (:@ src (:$ index))))
[13713]554
555(define-arm-vinsn mem-ref-s8 (((dest :s8))
556                              ((src :address)
557                               (index :s32)))
[13741]558  (ldrsb dest (:@ src index)))
[13713]559
[13741]560#+notyet
[13713]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
[13741]568
569#+notyet
[13713]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
[13741]578#+notyet
[13713]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
[13741]590#+notyet
[13713]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)
[13741]608                                           (index :s16const))
609                                          ((low (:u32 #.arm::imm0))
610                                           (high (:u32 #.arm::imm1))))
611  (ldrd low (:@ src (:$ index)))
612  (fmdrr dest low high))
[13713]613
614(define-arm-vinsn mem-ref-double-float (((dest :double-float))
615                                        ((src :address)
[13741]616                                         (index :s32))
617                                        ((low (:u32 #.arm::imm0))
618                                         (high (:u32 #.arm::imm1))))
619  (ldrd low (:@ src  index))
620  (fmdrr dest low high))
[13713]621
622(define-arm-vinsn mem-set-c-double-float (()
623                                          ((val :double-float)
624                                           (src :address)
[13741]625                                           (index :s16const))
626                                          ((low (:u32 #.arm::imm0))
627                                           (high (:u32 #.arm::imm1))))
628  (fmrrd low high src)
629  (strd low (:@ src (:$ index))))
[13713]630
631(define-arm-vinsn mem-set-double-float (()
632                                        ((val :double-float)
633                                         (src :address)
[13741]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)))
[13713]639
640(define-arm-vinsn mem-ref-c-single-float (((dest :single-float))
641                                          ((src :address)
[13741]642                                           (index :s16const))
643                                          ((temp :u32)))
644  (ldr temp (:@ src (:$ index)))
645  (fmsr dest temp))
[13713]646
647(define-arm-vinsn mem-ref-single-float (((dest :single-float))
648                                        ((src :address)
[13741]649                                         (index :s32))
650                                        ((temp :u32)))
651  (ldr temp (:@ src index))
652  (fmsr dest temp))
[13713]653
654(define-arm-vinsn mem-set-c-single-float (()
655                                          ((val :single-float)
656                                           (src :address)
[13741]657                                           (index :s16const))
658                                          ((temp :u32)))
659  (fmrs temp src)
660  (str temp (:@ src (:$ index))))
[13713]661
662(define-arm-vinsn mem-set-single-float (()
663                                        ((val :single-float)
664                                         (src :address)
[13741]665                                         (index :s32))
666                                        ((temp :u32)))
667  (fmrs temp src)
668  (str temp (:@ src (:$ index))))
[13713]669
670
671(define-arm-vinsn mem-set-c-address (()
672                                     ((val :address)
673                                      (src :address)
674                                      (index :s16const)))
[13741]675  (str val (:@ src (:$ index))))
[13713]676
677(define-arm-vinsn mem-set-address (()
678                                   ((val :address)
679                                    (src :address)
680                                    (index :s32)))
[13741]681  (str val (:@ src index)))
[13713]682
683(define-arm-vinsn mem-set-c-fullword (()
684                                      ((val :u32)
685                                       (src :address)
686                                       (index :s16const)))
[13741]687  (str val (:@ src (:$ index))))
[13713]688
689(define-arm-vinsn mem-set-fullword (()
690                                    ((val :u32)
691                                     (src :address)
692                                     (index :s32)))
[13741]693  (str val (:@ src index)))
[13713]694
695(define-arm-vinsn mem-set-c-halfword (()
696                                      ((val :u16)
697                                       (src :address)
698                                       (index :s16const)))
[13741]699  (strh val (:@ src (:$ index))))
[13713]700
701(define-arm-vinsn mem-set-halfword (()
702                                    ((val :u16)
703                                     (src :address)
704                                     (index :s32)))
[13741]705  (strh val (:@ src index)))
[13713]706
707(define-arm-vinsn mem-set-c-byte (()
708                                  ((val :u16)
709                                   (src :address)
710                                   (index :s16const)))
[13741]711  (strb val (:@ src (:$ index))))
[13713]712
713(define-arm-vinsn mem-set-byte (()
714                                ((val :u8)
715                                 (src :address)
716                                 (index :s32)))
[13741]717  (strb val (:@ src index)))
[13713]718
[13741]719#+later
[13713]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
[13741]730#+later
[13713]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
[13741]740#+later
[13713]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))
[13741]789  (mov tag (:lsl tag (:$ arm::fixnumshift))))
[13713]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))
[13741]800  (mov tag (:lsl tag (:$ arm::fixnumshift))))
[13713]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))
[13741]807  (ldrbeq code (:@ object (:$ arm::misc-subtag-offset))))
[13713]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))
[13741]814  (ldrbeq subtag (:@ object (:$ arm::misc-subtag-offset)))
815  (mov code (:lsl subtag (:$ arm::fixnumshift))))
[13713]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))
[13741]832  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
[13713]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))
[13741]842  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
[13713]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))
[13741]851  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
[13713]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))
[13741]861  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
[13713]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))
[13741]870  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
[13713]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)))
[13741]885  (and tag object (:$ arm::tagmask))
[13713]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)))))
[13741]904  (mov tag (:asr tag (:$ (- arm::nbits-in-word (+ 8 arm::fixnumshift)))))
[13713]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 (()
[13741]910                              ((object :lisp))
911                              ((temp :u32)))
912  (mov temp (:$ (lognot (ash #xff arm::fixnumshift))))
913  (tst object temp)
[13713]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)
[13741]943  (uuo-cerror-reg-not-xtype (:? ne) src (:$ arm::xtype-s32))
[13713]944  :got-it)
945
946
947(define-arm-vinsn require-u32 (()
948                               ((src :lisp))
949                               ((temp :u32)))
950  :again
[13741]951  (tst src (:$ (logior (ash 1 (1- arm::nbits-in-word)) arm::tagmask)))
[13713]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)
[13741]958  (ldr temp (:@ src (:$ arm::misc-header-offset)))
[13713]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))
[13741]983  (cmp tag (:$ arm::subtag-bignum))
984  (mov header (:lsr header (:$ arm::num-subtag-bits)))
[13713]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))
[13741]1002  (ldreq header (:@ src (:$ arm::misc-header-offset)))
[13713]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))
[13741]1066  (ldr dest (:@ src (:$ arm::misc-header-offset)))
1067  (mov temp (:$ arm::subtag-bignum))
[13713]1068  (orr temp temp (:$ (ash 1 arm::num-subtag-bits)))
1069  (cmp dest temp)
1070  (bne :maybe-two-digit)
[13741]1071  (ldr dest (:@ src (:$ arm::misc-data-offset)))
[13713]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)
[13741]1078  (ldreq temp (:@ src (:$ (+ arm::misc-data-offset 4))))
[13713]1079  (cmpeq temp (:$ 0))
[13741]1080  (ldreq dest (:@ src (:$ arm::misc-data-offset)))
[13713]1081  (uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-u32))
[13741]1082  :got-it)
[13713]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))
[13741]1092  (mov dest (:asr src (:$ arm::fixnumshift)))
[13713]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))
[13741]1097  (ldreq tag (:@ src (:$ arm::misc-header-offset)))
[13713]1098  (cmpeq dest tag)
[13741]1099  (ldreq dest (:@ src (:$ arm::misc-data-offset)))
[13713]1100  (uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-s32))
[13741]1101  :got-it)
[13713]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))))
[13741]1136  (mov dest (:asr dest (:$ 24)))
[13713]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)))
[13741]1145  (uuo-error-reg-not-xtype (:? ne) src (:$ arm::subtag-character)))
[13713]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
[13741]1154#+later
[13713]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
[13741]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))
[13713]1171
[13741]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))
[13713]1178
[13741]1179
[13713]1180(define-arm-vinsn shift-right-variable-word (((dest :u32))
1181                                             ((src :u32)
1182                                              (sh :u32)))
[13741]1183  (mov dest (:lsr src sh)))
[13713]1184
1185(define-arm-vinsn u32logandc2 (((dest :u32))
1186                               ((x :u32)
1187                                (y :u32)))
[13741]1188  (bic dest x y))
[13713]1189
1190(define-arm-vinsn u32logior (((dest :u32))
1191                             ((x :u32)
1192                              (y :u32)))
[13741]1193  (orr dest x y))
[13713]1194
1195(define-arm-vinsn complement-shift-count (((dest :u32))
1196                                          ((src :u32)))
[13741]1197  (rsb dest src (:$ 32)))
[13713]1198
1199(define-arm-vinsn extract-lowbyte (((dest :u32))
1200                                   ((src :lisp)))
[13741]1201  (and dest src (:$ arm::subtag-mask)))
[13713]1202
1203
1204
1205
1206(define-arm-vinsn trap-unless-fixnum (()
[13741]1207                                      ((object :lisp)))
1208  (tst object (:$ arm::fixnummask))
1209  (uuo-error-reg-not-lisptag (:? ne) object (:$ arm::tag-fixnum)))
[13713]1210
1211(define-arm-vinsn trap-unless-list (()
1212                                    ((object :lisp))
1213                                    ((tag :u8)))
[13751]1214  (and tag object (:$ arm::tagmask))
[13741]1215  (cmp tag (:$ arm::tag-list))
1216  (uuo-error-reg-not-lisptag (:? ne) object (:$ arm::tag-list)))
[13713]1217
1218(define-arm-vinsn trap-unless-single-float (()
1219                                            ((object :lisp))
[13741]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)))
[13713]1226
1227(define-arm-vinsn trap-unless-double-float (()
1228                                            ((object :lisp))
[13741]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)))
[13713]1235
1236
1237(define-arm-vinsn trap-unless-array-header (()
1238                                            ((object :lisp))
[13741]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)))
[13713]1245
1246(define-arm-vinsn trap-unless-macptr (()
1247                                      ((object :lisp))
[13741]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)))
[13713]1254
1255
1256
1257(define-arm-vinsn trap-unless-uvector (()
1258                                       ((object :lisp))
1259                                       ((tag :u8)))
[13741]1260  (and tag object (:$ arm::tagmask))
1261  (cmp tag (:$ arm::tag-misc))
1262  (uuo-error-reg-not-lisptag (:? ne) object (:$ arm::tag-misc)))
[13713]1263
1264
1265
1266(define-arm-vinsn trap-unless-character (()
1267                                         ((object :lisp))
1268                                         ((tag :u8)))
[13741]1269  (and tag object (:$ arm::subtag-mask))
1270  (cmp tag (:$ arm::subtag-character))
1271  (uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-character)))
[13713]1272
1273(define-arm-vinsn trap-unless-cons (()
1274                                    ((object :lisp))
1275                                    ((tag :u8)))
[13741]1276  (and tag object (:$ arm::fulltagmask))
1277  (cmp tag (:$ arm::fulltag-cons))
1278  (uuo-error-reg-not-fulltag (:? ne) object (:$ arm::fulltag-cons)))
[13713]1279
1280(define-arm-vinsn trap-unless-typecode= (()
1281                                         ((object :lisp)
1282                                          (tagval :u16const))
[13741]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)))
[13713]1289 
1290(define-arm-vinsn subtract-constant (((dest :imm))
1291                                     ((src :imm)
1292                                      (const :s16const)))
[13741]1293  (sub dest src (:$ const)))
[13713]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
[13741]1309#+later
[13713]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
[13741]1317#+later
[13713]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
1331                           
1332
1333
1334
[13751]1335(define-arm-vinsn compare (((crf :crf))
[13713]1336                           ((arg0 t)
1337                            (arg1 t))
1338                           ())
[13741]1339  (cmp arg0 arg1))
[13713]1340
[13751]1341(define-arm-vinsn compare-to-nil (((crf :crf))
[13713]1342                                  ((arg0 t)))
[13741]1343  (cmp arg0 (:$ arm::nil-value)))
[13713]1344
[13741]1345(define-arm-vinsn compare-logical (
[13713]1346                                   ((arg0 t)
1347                                    (arg1 t))
1348                                   ())
[13741]1349  (cmp  arg0 arg1))
[13713]1350
[13741]1351(define-arm-vinsn double-float-compare (()
[13713]1352                                        ((arg0 :double-float)
1353                                         (arg1 :double-float))
1354                                        ())
[13741]1355  (fcmped arg0 arg1)
1356  (fmstat))
[13713]1357             
1358
1359(define-arm-vinsn double-float+-2 (((result :double-float))
1360                                   ((x :double-float)
1361                                    (y :double-float)))
1362  (faddd result x y))
1363
1364(define-arm-vinsn double-float--2 (((result :double-float))
1365                                   ((x :double-float)
1366                                    (y :double-float)))
1367  (fsubd result x y))
1368
1369(define-arm-vinsn double-float*-2 (((result :double-float))
1370                                   ((x :double-float)
1371                                    (y :double-float)))
1372  (fmuld result x y))
1373
1374(define-arm-vinsn double-float/-2 (((result :double-float))
1375                                   ((x :double-float)
1376                                    (y :double-float)))
1377  (fdivd result x y))
1378
1379(define-arm-vinsn single-float+-2 (((result :single-float))
1380                                   ((x :single-float)
1381                                    (y :single-float))
[13741]1382                                   ())
[13713]1383  (fadds result x y))
1384
1385(define-arm-vinsn single-float--2 (((result :single-float))
1386                                   ((x :single-float)
1387                                    (y :single-float)))
1388  (fsubs result x y))
1389
1390(define-arm-vinsn single-float*-2 (((result :single-float))
1391                                   ((x :single-float)
1392                                    (y :single-float)))
1393  (fmuls result x y))
1394
1395(define-arm-vinsn single-float/-2 (((result :single-float))
1396                                   ((x :single-float)
1397                                    (y :single-float)))
1398  (fdivs result x y))
1399
1400
1401
1402
1403
[13741]1404(define-arm-vinsn compare-unsigned (()
[13713]1405                                    ((arg0 :imm)
1406                                     (arg1 :imm))
1407                                    ())
[13741]1408  (cmp arg0 arg1))
[13713]1409
[13741]1410(define-arm-vinsn compare-signed-s16const (()
[13713]1411                                           ((arg0 :imm)
1412                                            (imm :s16const))
1413                                           ())
[13741]1414  (cmp arg0 (:$ imm)))
[13713]1415
[13741]1416(define-arm-vinsn compare-unsigned-u16const (()
[13713]1417                                             ((arg0 :u32)
1418                                              (imm :u16const))
1419                                             ())
[13741]1420  (cmp arg0 (:$ imm)))
[13713]1421
1422
1423
1424;; Extract a constant bit (0-31) from src; make it be bit 31 of dest.
1425;; Bitnum is treated mod 32.
[13741]1426#+later
[13713]1427(define-arm-vinsn extract-constant-arm-bit (((dest :u32))
1428                                            ((src :imm)
1429                                             (bitnum :u16const))
1430                                            ())
1431  (rlwinm dest src (:apply + 1 bitnum) 31 31))
1432
1433
[13741]1434#+later
[13713]1435(define-arm-vinsn set-constant-arm-bit-to-variable-value (((dest :u32))
1436                                                          ((src :u32)
1437                                                           (bitval :u32) ; 0 or 1
1438                                                           (bitnum :u8const)))
1439  (rlwimi dest bitval (:apply - 32 bitnum) bitnum bitnum))
1440
[13741]1441#+later
[13713]1442(define-arm-vinsn set-constant-arm-bit-to-1 (((dest :u32))
1443                                             ((src :u32)
1444                                              (bitnum :u8const)))
1445  ((:pred < bitnum 16)
1446   (oris dest src (:apply ash #x8000 (:apply - bitnum))))
1447  ((:pred >= bitnum 16)
1448   (ori dest src (:apply ash #x8000 (:apply - (:apply - bitnum 16))))))
1449
[13741]1450#+later
[13713]1451(define-arm-vinsn set-constant-arm-bit-to-0 (((dest :u32))
1452                                             ((src :u32)
1453                                              (bitnum :u8const)))
1454  (rlwinm dest src 0 (:apply logand #x1f (:apply 1+ bitnum)) (:apply logand #x1f (:apply 1- bitnum))))
1455
[13741]1456
1457#+later
[13713]1458(define-arm-vinsn insert-bit-0 (((dest :u32))
1459                                ((src :u32)
1460                                 (val :u32)))
1461  (rlwimi dest val 0 0 0))
1462 
1463;;; The bit number is boxed and wants to think of the least-significant bit as 0.
1464;;; Imagine that.
1465;;; To turn the boxed, lsb-0 bitnumber into an unboxed, msb-0 rotate count,
1466;;; we (conceptually) unbox it, add arm::fixnumshift to it, subtract it from
1467;;; 31, and add one.  This can also be done as "unbox and subtract from 28",
1468;;; I think ...
1469;;; Actually, it'd be "unbox, then subtract from 30".
[13741]1470#+later
[13713]1471(define-arm-vinsn extract-variable-non-insane-bit (((dest :u32))
1472                                                   ((src :imm)
1473                                                    (bit :imm))
1474                                                   ((temp :u32)))
1475  (srwi temp bit arm::fixnumshift)
1476  (subfic temp temp (- 32 arm::fixnumshift))
1477  (rlwnm dest src temp 31 31))
1478                                               
1479;;; Operations on lists and cons cells
1480
1481(define-arm-vinsn %cdr (((dest :lisp))
1482                        ((src :lisp)))
[13741]1483  (ldr dest (:@ src (:$ arm::cons.cdr))))
[13713]1484
1485(define-arm-vinsn %car (((dest :lisp))
1486                        ((src :lisp)))
[13741]1487  (ldr dest (:@ src (:$ arm::cons.car))))
[13713]1488
1489(define-arm-vinsn %set-car (()
1490                            ((cell :lisp)
1491                             (new :lisp)))
[13741]1492  (str cell (:@ new (:$ arm::cons.car))))
[13713]1493
1494(define-arm-vinsn %set-cdr (()
1495                            ((cell :lisp)
1496                             (new :lisp)))
[13741]1497  (str cell (:@ new (:$ arm::cons.cdr))))
[13713]1498
[13741]1499#+later
[13713]1500(define-arm-vinsn load-adl (()
1501                            ((n :u32const)))
1502  (lis nargs (:apply ldb (byte 16 16) n))
1503  (ori nargs nargs (:apply ldb (byte 16 0) n)))
1504                           
1505(define-arm-vinsn set-nargs (()
1506                             ((n :s16const)))
[13741]1507  (mov nargs (:$ (:apply ash n arm::word-shift))))
[13713]1508
1509(define-arm-vinsn scale-nargs (()
1510                               ((nfixed :s16const)))
1511  ((:pred > nfixed 0)
[13741]1512   (add nargs nargs (:$ (:apply - (:apply ash nfixed arm::word-shift))))))
[13713]1513                           
1514
1515
1516(define-arm-vinsn (vpush-register :push :node :vsp)
1517    (()
1518     ((reg :lisp)))
[13741]1519  (str reg (:@! vsp (:$ (- arm::node-size)))))
[13713]1520
1521(define-arm-vinsn (vpush-register-arg :push :node :vsp :outgoing-argument)
1522    (()
1523     ((reg :lisp)))
[13741]1524  (str reg (:@! vsp (:$ (- arm::node-size)))))
[13713]1525
[13751]1526(define-arm-vinsn (vpush-xyz :push :node :vsp) (() ())
1527  (stmdb (:! vsp) (arg_z arg_y arg_x)))
1528
1529(define-arm-vinsn (vpush-yz :push :node :vsp) (() ())
1530  (stmdb (:! vsp) (arg_z arg_y)))
1531
1532   
1533
[13713]1534(define-arm-vinsn (vpop-register :pop :node :vsp)
1535    (((dest :lisp))
1536     ())
1537  (ldr dest (:@+ vsp (:$ arm::node-size))))
1538
[13751]1539(define-arm-vinsn (pop-argument-registers :pop :node :vsp) (()
1540                                                            ())
1541  (cmp nargs (:$ 0))
1542  (beq :done)
1543  (cmp nargs (:$ (* 2 arm::fixnumshift)))
1544  (ldrlt arg_z (:@+ vsp (:$ arm::node-size)))
1545  (ldmiaeq (:! vsp) (arg_z arg_y))
1546  (ldmiagt (:! vsp) (arg_z arg_y arg_x))
1547  :done)
[13713]1548
[13751]1549
1550
[13713]1551(define-arm-vinsn copy-node-gpr (((dest :lisp))
1552                                 ((src :lisp)))
1553  ((:not (:pred =
1554                (:apply %hard-regspec-value dest)
1555                (:apply %hard-regspec-value src)))
1556   (mov dest src)))
1557
1558(define-arm-vinsn copy-gpr (((dest t))
1559                            ((src t)))
1560  ((:not (:pred =
1561                (:apply %hard-regspec-value dest)
1562                (:apply %hard-regspec-value src)))
1563   (mov dest src)))
1564
1565
1566(define-arm-vinsn copy-fpr (((dest :double-float))
1567                            ((src :double-float)))
1568  ((:not (:pred =
1569                (:apply %hard-regspec-value dest)
1570                (:apply %hard-regspec-value src)))
[13741]1571   (fcpyd dest src)))
[13713]1572
1573(define-arm-vinsn vcell-ref (((dest :lisp))
1574                             ((vcell :lisp)))
[13741]1575  (ldr dest (:@ vcell (:$ arm::misc-data-offset))))
[13713]1576
1577
1578(define-arm-vinsn make-vcell (((dest :lisp))
1579                              ((closed (:lisp :ne dest)))
1580                              ((header :u32)))
[13741]1581  (mov header (:$ arm::subtag-value-cell))
1582  (orr header header (:$ (ash arm::value-cell.element-count arm::num-subtag-bits)))
1583  (sub allocptr allocptr (:$ (- arm::value-cell.size arm::fulltag-misc)))
1584  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
1585  (cmp allocptr dest)
1586  (uuo-alloc-trap (:? lo))
1587  (str header (:@ allocptr (:$ arm::misc-header-offset)))
1588  (mov dest allocptr)
1589  (bic allocptr allocptr (:$ arm::fulltagmask))
1590  (str closed (:@ dest (:$ arm::value-cell.value))))
[13713]1591
[13741]1592(define-arm-vinsn make-stack-vcell (((dest :lisp))
1593                                    ((closed :lisp))
1594                                    ((header :u32)))
1595  (mov header (:$ arm::subtag-value-cell))
1596  (orr header header (:$ (ash arm::value-cell.element-count arm::num-subtag-bits)))
1597  (stmdb (:! sp) (closed header)))
[13713]1598
[13741]1599(define-arm-vinsn make-stack-cons (((dest :lisp))
1600                                   ((car :lisp) (cdr :lisp))
1601                                   ((header (:u32 #.arm::imm0))
1602                                    (zero (:u32 #.arm::imm1))))
1603  (mov header (:$ arm::subtag-simple-vector))
1604  (mov zero (:$ 0))
1605  (orr header header (:$ (ash 3 arm::num-subtag-bits)))
1606  ((:pred <
1607          (:apply %hard-regspec-value cdr)
1608          (:apply %hard-regpsec-value car))
1609   (stmdb (:! sp) (car cdr zero header)))
1610  ((:not (:pred <
1611                (:apply %hard-regspec-value cdr)
1612                (:apply %hard-regpsec-value car)))
1613   (stmdb (:! sp) (cdr car zero header))
1614   (str car (:@ sp (:$ 12)))
1615   (str cdr (:@ sp (:$ 8))))
1616  (add dest sp (:$ (+ arm::dnode-size arm::fulltag-cons))))
[13713]1617
1618
1619(define-arm-vinsn %closure-code% (((dest :lisp))
1620                                  ())
[13741]1621  (mov dest (:$ arm::nil-value))
1622  (ldr dest (:@ dest (:$ (:apply + arm::symbol.vcell (arm::nrs-offset %closure-code%))))))
[13713]1623
1624
1625(define-arm-vinsn single-float-bits (((dest :u32))
1626                                     ((src :lisp)))
[13741]1627  (ldr dest (:@ src (:$ arm::single-float.value))))
[13713]1628
1629(define-arm-vinsn (call-subprim :call :subprim-call) (()
1630                                                      ((spno :s32const)))
1631  (bl spno))
1632
1633(define-arm-vinsn (jump-subprim :jumpLR) (()
1634                                          ((spno :s32const)))
1635  (ba spno))
1636
1637;;; Same as "call-subprim", but gives us a place to
1638;;; track args, results, etc.
1639(define-arm-vinsn (call-subprim-0 :call :subprim-call) (((dest t))
1640                                                        ((spno :s32const)))
1641  (bl spno))
1642
1643(define-arm-vinsn (call-subprim-1 :call :subprim-call) (((dest t))
1644                                                        ((spno :s32const)
1645                                                         (z t)))
1646  (bl spno))
1647 
1648(define-arm-vinsn (call-subprim-2 :call :subprim-call) (((dest t))
1649                                                        ((spno :s32const)
1650                                                         (y t)
1651                                                         (z t)))
1652  (bl spno))
1653
1654(define-arm-vinsn (call-subprim-3 :call :subprim-call) (((dest t))
1655                                                        ((spno :s32const)
1656                                                         (x t)
1657                                                         (y t)
1658                                                         (z t)))
1659  (bl spno))
1660
1661
1662
1663(define-arm-vinsn ref-interrupt-level (((dest :imm))
1664                                       ()
1665                                       ((temp :u32)))
[13741]1666  (ldr temp (:@ rcontext (:$ arm::tcr.tlb-pointer)))
1667  (ldr dest (:@ temp (:$ arm::INTERRUPT-LEVEL-BINDING-INDEX))))
[13713]1668
1669                         
1670;;; Unconditional (pc-relative) branch
1671(define-arm-vinsn (jump :jump) (()
1672                                ((label :label)))
1673  (b label))
1674
1675(define-arm-vinsn (call-label :call) (()
1676                                      ((label :label)))
1677  (bl label))
1678
1679;;; just like JUMP, only (implicitly) asserts that the following
1680;;; code is somehow reachable.
1681(define-arm-vinsn (non-barrier-jump :xref) (()
1682                                            ((label :label)))
1683  (b label))
1684
1685
1686(define-arm-vinsn (cbranch-true :branch) (()
1687                                          ((label :label)
[13751]1688                                           (crf :crf)
[13713]1689                                           (crbit :u8const)))
1690  (b (:? crbit) label))
1691
1692(define-arm-vinsn (cbranch-false :branch) (()
1693                                           ((label :label)
[13751]1694                                            (crf :crf)
[13713]1695                                            (crbit :u8const)))
1696  (b (:~ crbit) label))
1697
[13751]1698(define-arm-vinsn cond->boolean (((dest :imm))
1699                                 ((cond :u8const)))
1700  (mov dest (:$ arm::nil-value))
1701  (add (:? cond) dest dest (:$ arm::t-offset)))
[13713]1702
1703
1704
1705(define-arm-vinsn lisp-word-ref (((dest t))
1706                                 ((base t)
1707                                  (offset t)))
1708  (ldr dest (:@ base offset)))
1709
1710(define-arm-vinsn lisp-word-ref-c (((dest t))
1711                                   ((base t)
1712                                    (offset :s16const)))
1713  (ldr dest (:@ base (:$ offset))))
1714
1715 
1716
1717;; Load an unsigned, 32-bit constant into a destination register.
1718(define-arm-vinsn (lri :constant-ref) (((dest :imm))
1719                                       ((intval :u32const))
1720                                       ())
1721  ((:pred arm::encode-arm-immediate intval)
1722   (mov dest (:$ intval)))
1723  ((:not (:pred arm::encode-arm-immediate intval))
1724   ((:pred arm::encode-arm-immediate (:apply lognot intval))
1725    (mvn dest (:$ (:apply lognot intval))))
1726   ((:not (:pred arm::encode-arm-immediate (:apply lognot intval)))
1727    (:section :data)
1728    :const
1729    (:word intval)
1730    (:section :text)
1731    (ldr dest :const))))
1732
1733
1734#+notyet
1735(define-arm-vinsn (discard-temp-frame :tsp :pop :discard) (()
1736                                                           ())
[13741]1737  (ldr arm::tsp (:@ arm::tsp (:$ 0))))
[13713]1738
1739
1740(define-arm-vinsn alloc-c-frame (()
1741                                 ((n-c-args :u16const))
1742                                 ((header :u32)
1743                                  (size :imm)
1744                                  (prevsp :imm)))
1745  (mov header (:$ (:apply ash (:apply + 1 (:apply logandc2 (:apply + 4 1 n-c-args) 1)) arm::num-subtag-bits)))
1746  (mov size (:lsr header (:$ (- arm::num-subtag-bits arm::word-shift))))
[13741]1747  (orr header header (:$ arm::subtag-u32-vector))
[13713]1748  (mov prevsp sp)
1749  (add size size (:$ arm::node-size))
1750  (str header (:-@! sp size))
1751  (str prevsp (:@ sp (:$ 4))))
1752
1753(define-arm-vinsn alloc-variable-c-frame (()
1754                                          ((n-c-args :lisp))
1755                                          ((header :u32)
1756                                           (size :imm)
1757                                           (prevsp :imm)))
1758  (add size n-c-args (:$ (ash (+ 4 1) arm::word-shift)))
1759  (bic size size (:$ arm::fixnumone))
1760  (add size size (:$ arm::fixnumone))
1761  (mov prevsp sp)
1762  (mov header (:lsl size (:$ (- arm::num-subtag-bits arm::fixnumshift))))
1763  (add size size (:$ arm::fixnumone))
1764  (orr header header (:$ arm::subtag-u32-vector))
1765  (str header (:-@! sp size))
1766  (str prevsp (:@ sp (:$ 4))))
1767
1768
1769
1770;;; We should rarely have to do this - (#_foo x y (if .. (return-from ...)))
1771;;; is one of the few cases that I can think of - but if we ever do, we
1772;;; might as well exploit the fact that we stored the previous sp at
1773;;; offset 4 in the C frame.
1774(define-arm-vinsn (discard-c-frame :csp :pop :discard) (()
1775                                                        ())
1776  (ldr sp (:@ sp (:$ 4))))
1777
1778
1779
1780
1781(define-arm-vinsn set-c-arg (()
1782                             ((argval :u32)
1783                              (argnum :u16const)))
1784  (str argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift))))))
1785
[13741]1786#+notyet
[13713]1787(define-arm-vinsn set-single-c-arg (()
1788                                    ((argval :single-float)
1789                                     (argnum :u16const)))
1790  (fsts argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift))))))
1791
[13741]1792#+notyet
[13713]1793(define-arm-vinsn set-double-c-arg (()
1794                                    ((argval :double-float)
1795                                     (argnum :u16const)))
1796  (fstd argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift))))))
1797
1798
1799
1800(define-arm-vinsn (load-nil :constant-ref) (((dest t))
1801                                            ())
1802  (mov dest (:$ arm::nil-value)))
1803
1804(define-arm-vinsn (load-t :constant-ref) (((dest t))
1805                                          ())
1806  (mov dest (:$ arm::nil-value))
1807  (add dest dest (:$ arm::t-offset)))
1808
1809
[13741]1810
[13713]1811(define-arm-vinsn (ref-constant :constant-ref) (((dest :lisp))
1812                                                ((src :s16const)))
1813  (ldr dest (:@ fn (:$ (:apply + arm::misc-data-offset (:apply ash (:apply + src 2) 2))))))
1814
1815(define-arm-vinsn ref-indexed-constant (((dest :lisp))
1816                                        ((idxreg :s32)))
[13741]1817  (ldr dest (:@ arm::fn idxreg)))
[13713]1818
1819
1820(define-arm-vinsn cons (((dest :lisp))
1821                        ((newcar :lisp)
[13741]1822                         (newcdr :lisp))
1823                        ((allocbase :imm)))
1824  (sub allocptr allocptr (:$ (- arm::cons.size arm::fulltag-cons)))
1825  (ldr allocbase (:@ rcontext (:$ arm::tcr.save-allocbase)))
1826  (cmp allocptr allocbase)
1827  (uuo-alloc-trap (:? lo))
1828  (str newcdr (:@ allocptr (:$ arm::cons.cdr)))
1829  (str newcar (:@ allocptr (:$ arm::cons.car)))
1830  (mov dest allocptr)
1831  (bic allocptr allocptr (:$ arm::fulltagmask)))
[13713]1832
1833
1834
1835;; subtag had better be a ARM-NODE-SUBTAG of some sort!
1836(define-arm-vinsn %arm-gvector (((dest :lisp))
1837                                ((Rheader :u32) 
1838                                 (nbytes :u32const))
1839                                ((immtemp0 :u32)
[13741]1840                                 (nodetemp :lisp)))
1841 
1842  (sub allocptr allocptr (:$ (:apply logand #xff
1843                                 (:apply -
1844                                    (:apply logand (lognot 7)
1845                                    (:apply + (+ 7 4) nbytes))
1846                                    arm::fulltag-misc))))
1847  ((:pred > (:apply -
1848                    (:apply logand (lognot 7)
1849                            (:apply + (+ 7 4) nbytes))
1850                    arm::fulltag-misc) #xff)
1851   (sub allocptr allocptr (:$ (:apply logand #xff00
1852                                 (:apply -
1853                                    (:apply logand (lognot 7)
1854                                    (:apply + (+ 7 4) nbytes))
1855                                    arm::fulltag-misc)))))
1856  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
1857  (cmp allocptr dest)
1858  (uuo-alloc-trap (:? lo))
1859  (str Rheader (:@ allocptr (:$ arm::misc-header-offset)))
1860  (mov dest allocptr)
1861  (bic allocptr allocptr (:$ arm::fulltagmask))
[13713]1862  ((:not (:pred = nbytes 0))
[13741]1863   (mov immtemp0 (:$ (:apply + arm::misc-data-offset nbytes)))
[13713]1864   :loop
[13741]1865   (sub immtemp0 immtemp0 (:$ 4))
1866   (cmp immtemp0 (:$ arm::misc-data-offset))
1867   (ldr nodetemp (:@+ vsp (:$ arm::node-size)))
1868   (str nodetemp (:@ dest immtemp0))
1869   (bne :loop)))
[13713]1870
1871;; allocate a small (phys size <= 32K bytes) misc obj of known size/subtag
1872(define-arm-vinsn %alloc-misc-fixed (((dest :lisp))
1873                                     ((Rheader :u32)
1874                                      (nbytes :u32const)))
[13741]1875  (sub allocptr allocptr (:$ (:apply
1876                              logand #xff
1877                              (:apply - (:apply logand (lognot 7)
1878                                                (:apply + (+ 7 4) nbytes))))))
1879  ((:pred > (:apply -
1880                    (:apply logand (lognot 7)
1881                            (:apply + (+ 7 4) nbytes))
1882                    arm::fulltag-misc) #xff)
1883   (sub allocptr allocptr (:$ (:apply logand #xff00
1884                                 (:apply -
1885                                    (:apply logand (lognot 7)
1886                                    (:apply + (+ 7 4) nbytes))
1887                                    arm::fulltag-misc)))))
1888  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
1889  (cmp allocptr dest)
1890  (uuo-alloc-trap (:? lo))
1891  (str Rheader (:@ allocptr (:$ arm::misc-header-offset)))
1892  (mov dest allocptr)
1893  (bic allocptr allocptr (:$ arm::fulltagmask)))
[13713]1894
1895(define-arm-vinsn (vstack-discard :vsp :pop :discard) (()
1896                                                       ((nwords :u32const)))
1897  ((:not (:pred = nwords 0))
[13741]1898   (add vsp vsp (:$ (:apply ash nwords arm::word-shift)))))
[13713]1899
1900
1901(define-arm-vinsn lcell-load (((dest :lisp))
1902                              ((cell :lcell)
1903                               (top :lcell)))
[13741]1904  (ldr dest (:@ vsp (:$ (:apply - 
[13713]1905                    (:apply - (:apply calc-lcell-depth top) 4)
[13741]1906                    (:apply calc-lcell-offset cell))))))
[13713]1907
1908(define-arm-vinsn vframe-load (((dest :lisp))
1909                               ((frame-offset :u16const)
1910                                (cur-vsp :u16const)))
[13741]1911  (ldr dest (:@ vsp (:$ (:apply - (:apply - cur-vsp 4) frame-offset)))))
[13713]1912
1913(define-arm-vinsn lcell-store (()
1914                               ((src :lisp)
1915                                (cell :lcell)
1916                                (top :lcell)))
[13741]1917  (str src (:@ vsp (:$ (:apply - 
[13713]1918                   (:apply - (:apply calc-lcell-depth top) 4)
[13741]1919                   (:apply calc-lcell-offset cell))))))
[13713]1920
1921(define-arm-vinsn vframe-store (()
1922                                ((src :lisp)
1923                                 (frame-offset :u16const)
1924                                 (cur-vsp :u16const)))
[13741]1925  (str src (:@ vsp (:$ (:apply - (:apply - cur-vsp 4) frame-offset)))))
[13713]1926
1927(define-arm-vinsn load-vframe-address (((dest :imm))
1928                                       ((offset :s16const)))
[13741]1929  (add dest vsp (:$ offset)))
[13713]1930
1931(define-arm-vinsn copy-lexpr-argument (()
1932                                       ()
1933                                       ((temp :lisp)))
[13741]1934  (ldr temp (:@ vsp nargs))
1935  (str temp (:@! vsp (:$ (- arm::node-size)))))
[13713]1936
1937;;; Boxing/unboxing of integers.
1938
1939;;; Treat the low 8 bits of VAL as an unsigned integer; set RESULT to the equivalent fixnum.
1940(define-arm-vinsn u8->fixnum (((result :imm)) 
1941                              ((val :u8)) 
1942                              ())
[13741]1943  (mov result (:lsr val (:$ 24)))
1944  (mov result (:lsr val (:$ (- 24 arm::fixnumshift)))))
[13713]1945
1946;;; Treat the low 8 bits of VAL as a signed integer; set RESULT to the equivalent fixnum.
1947(define-arm-vinsn s8->fixnum (((result :imm)) 
1948                              ((val :s8)) 
1949                              ())
[13741]1950  (mov result (:lsr val (:$ 24)))
1951  (mov result (:asr val (:$ (- 24 arm::fixnumshift)))))
[13713]1952
1953
1954;;; Treat the low 16 bits of VAL as an unsigned integer; set RESULT to the equivalent fixnum.
1955(define-arm-vinsn u16->fixnum (((result :imm)) 
1956                               ((val :u16)) 
1957                               ())
[13741]1958  (mov result (:lsl val (:$ 16)))
1959  (mov result (:lsr result (:$ (- 16 arm::fixnumshift)))))
[13713]1960
1961;;; Treat the low 16 bits of VAL as a signed integer; set RESULT to the equivalent fixnum.
1962(define-arm-vinsn s16->fixnum (((result :imm)) 
1963                               ((val :s16)) 
1964                               ())
1965  (mov result (:lsl val (:$ 16)))
1966  (mov result (:asr result (:$ (- 16 arm::fixnumshift)))))
1967
1968(define-arm-vinsn fixnum->s16 (((result :s16))
1969                               ((src :imm)))
1970  (mov result (:asr src (:$ arm::fixnumshift))))
1971
1972;;; A signed 32-bit untagged value can be at worst a 1-digit bignum.
1973;;; There should be something very much like this that takes a stack-consed
1974;;; bignum result ...
1975(define-arm-vinsn s32->integer (((result :lisp))
1976                                ((src :s32))
1977                                ((temp :s32)))       
1978  (adds temp src src)
1979  (addsvc result temp temp)
1980  (bvc :done)
1981  (mov temp (:$ arm::subtag-bignum))
1982  (orr temp temp (:$ (ash 1 arm::num-subtag-bits)))
[13741]1983  (add allocptr allocptr (:$ (- arm::fulltag-misc 8)))
1984  (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase)))
[13713]1985  (cmp allocptr result)
[13741]1986  (uuo-alloc-trap (:? lo))
[13713]1987  (str temp (:@ allocptr (:$ arm::misc-header-offset)))
1988  (mov result allocptr)
1989  (bic allocptr allocptr (:$ arm::fulltagmask))
1990  (str src (:@ result (:$ arm::misc-data-offset)))
1991  :done)
1992
1993
1994;;; An unsigned 32-bit untagged value can be either a 1 or a 2-digit bignum.
1995(define-arm-vinsn u32->integer (((result :lisp))
1996                                ((src :u32))
[13741]1997                                ((temp :s32)
[13713]1998                                 (size :u32)))
[13741]1999  (tst src (:$ #xe0000000))
2000  (moveq result (:lsr src (:$ arm::fixnumshift)))
2001  (beq :done)
2002  (cmp src (:$ 0))
2003  (mov temp (:$ arm::subtag-bignum))
2004  (movgt size (:$ (- (* 2 arm::dnode-size) arm::fulltag-misc)))
2005  (orrgt temp temp (:$ (ash 2 arm::num-subtag-bits)))
2006  (movlt size (:$ (- (* 1 arm::dnode-size) arm::fulltag-misc)))
2007  (orrlt temp temp (:$ (ash 1 arm::num-subtag-bits)))
2008  (sub allocptr allocptr size)
2009  (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase)))
2010  (cmp allocptr result)
2011  (uuo-alloc-trap (:? lo))
2012  (str temp (:@ allocptr (:$ arm::misc-header-offset)))
2013  (mov result allocptr)
2014  (bic allocptr allocptr (:$ arm::fulltagmask))
2015  (str src (:@ result (:$ arm::misc-data-offset)))
[13713]2016  :done)
2017
2018(define-arm-vinsn u16->u32 (((dest :u32))
2019                            ((src :u16)))
[13741]2020  (mov dest (:$ #xff))
2021  (orr dest dest (:$ #xff00))
2022  (and dest dest src))
[13713]2023
2024(define-arm-vinsn u8->u32 (((dest :u32))
2025                           ((src :u8)))
[13741]2026  (and dest src (:$ #xff)))
[13713]2027
2028
2029(define-arm-vinsn s16->s32 (((dest :s32))
2030                            ((src :s16)))
[13741]2031  (mov dest (:lsl src (:$ 16)))
2032  (mov dest (:asr src (:$ 16))))
[13713]2033
2034(define-arm-vinsn s8->s32 (((dest :s32))
2035                           ((src :s8)))
[13741]2036  (mov dest (:lsl src (:$ 24)))
2037  (mov dest (:asr src (:$ 24))))
[13713]2038
2039
2040;;; ... of floats ...
2041
2042;;; Heap-cons a double-float to store contents of FPREG.  Hope that we don't do
2043;;; this blindly.
2044(define-arm-vinsn double->heap (((result :lisp)) ; tagged as a double-float
2045                                ((fpreg :double-float)) 
[13741]2046                                ((header-temp (:u32 #.arm::imm0))
2047                                 (high (:u32 #.arm::imm1))))
2048  (mov header-temp (:$ arm::subtag-double-float))
2049  (orr header-temp header-temp (:$ (ash arm::double-float.element-count arm::num-subtag-bits)))
2050  (sub allocptr allocptr (:$ (- arm::double-float.size arm::fulltag-misc)))
2051  (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase)))
2052  (cmp allocptr result)
2053  (uuo-alloc-trap (:? lo))
2054  (str header-temp (:@ allocptr (:$ arm::misc-header-offset)))
2055  (mov result allocptr)
2056  (bic allocptr allocptr (:$ arm::fulltagmask))
2057  (fmrrd header-temp high fpreg)
2058  (strd header-temp (:@ result (:$ arm::double-float.value))))
[13713]2059
2060
2061;;; This is about as bad as heap-consing a double-float.  (In terms of
2062;;; verbosity).  Wouldn't kill us to do either/both out-of-line, but
2063;;; need to make visible to compiler so unnecessary heap-consing can
2064;;; be elided.
2065(define-arm-vinsn single->node (((result :lisp)) ; tagged as a single-float
2066                                ((fpreg :single-float))
2067                                ((header-temp :u32)))
[13741]2068  (mov header-temp (:$ arm::subtag-single-float))
2069  (orr header-temp header-temp (:$ (ash arm::single-float.element-count arm::num-subtag-bits)))
2070  (sub allocptr allocptr (:$ (- arm::single-float.size arm::fulltag-misc)))
2071  (ldr result (:@ rcontext (:$ arm::tcr.save-allocbase)))
2072  (cmp allocptr result)
2073  (uuo-alloc-trap (:? lo))
2074  (str header-temp (:@ allocptr (:$ arm::misc-header-offset)))
2075  (mov result allocptr)
2076  (bic allocptr allocptr (:$ arm::fulltagmask))
2077  (fmrs header-temp fpreg)
2078  (str header-temp (:@ result (:$ arm::single-float.value))))
[13713]2079
2080
[13741]2081
[13713]2082;;; "dest" is preallocated, presumably on a stack somewhere.
2083(define-arm-vinsn store-double (()
2084                                ((dest :lisp)
2085                                 (source :double-float))
[13741]2086                                ((low (:u32 #.arm::imm0))
2087                                 (high (:u32 #.arm::imm1))))
2088  (fmrrd low high source)
2089  (str low (:@ dest (:$ arm::double-float.value))))
[13713]2090
2091(define-arm-vinsn get-double (((target :double-float))
2092                              ((source :lisp))
[13741]2093                              ((low (:u32 #.arm::imm0))
2094                               (high (:u32 #.arm::imm1))))
2095  (ldrd low (:@ source (:$ arm::double-float.value)))
2096  (fmdrr target low high))
[13713]2097
2098;;; Extract a double-float value, typechecking in the process.
2099;;; IWBNI we could simply call the "trap-unless-typecode=" vinsn here,
2100;;; instead of replicating it ..
2101
2102(define-arm-vinsn get-double? (((target :double-float))
2103                               ((source :lisp))
[13741]2104                               ((low (:u32 #.arm::imm0))
2105                                (high (:u32 #.arm::imm1))))
2106  (and low source (:$ arm::tagmask))
2107  (cmp low (:$ arm::tag-misc))
2108  (ldrbeq low (:@ source (:$ arm::misc-subtag-offset)))
2109  (cmp imm0 (:$ arm::subtag-double-float))
[13713]2110  (uuo-error-reg-not-xtype (:? ne) source (:$ arm::subtag-double-float))
[13741]2111  (ldrd imm0 (:@ source (:$ arm::double-float.value)))
2112  (fmdrr target imm0 imm1))
[13713]2113 
2114
2115(define-arm-vinsn double-to-single (((result :single-float))
2116                                    ((arg :double-float)))
[13741]2117  (fcvtsd result arg))
[13713]2118
2119(define-arm-vinsn store-single (()
2120                                ((dest :lisp)
2121                                 (source :single-float))
[13741]2122                                ((temp :u32)))
2123  (fmrs temp source)
2124  (str temp (:@ dest (:$ arm::single-float.value))))
[13713]2125
2126(define-arm-vinsn get-single (((target :single-float))
2127                              ((source :lisp))
[13741]2128                              ((temp :u32)))
2129  (ldr temp (:@ source (:$ arm::single-float.value)))
2130  (fmsr target temp))
[13713]2131
2132;;; ... of characters ...
2133
2134
2135(define-arm-vinsn character->fixnum (((dest :lisp))
2136                                     ((src :lisp))
2137                                     ())
2138  (bic dest src (:$ arm::subtag-mask))
2139  (mov dest (:lsr dest (:$ (- arm::ncharcodebits arm::fixnumshift)))))
2140
2141(define-arm-vinsn character->code (((dest :u32))
2142                                   ((src :lisp)))
2143  (mov dest (:lsr src (:$ arm::charcode-shift))))
2144
2145
2146(define-arm-vinsn fixnum->char (((dest :lisp))
2147                                ((src :imm))
2148                                ((temp :u32)
[13741]2149                                 (temp2 :u32)))
2150  (mov temp2 (:$ #x7f00))
2151  (mov temp (:lsr src (:$ (+ arm::fixnumshift 1))))
2152  (orr temp2 temp2 (:$ #xff))
2153  (cmp temp temp2)
2154  (mov temp (:lsr src (:$ (+ arm::fixnumshift 11))))
[13713]2155  (beq :bad)
[13741]2156  (cmp temp (:$ 27))
2157  (mov dest (:lsr src (:$ (- arm::charcode-shift arm::fixnumshift))))
[13713]2158  :bad
[13741]2159  (moveq dest (:$ arm::nil-value))
2160  (addne dest dest (:$ arm::subtag-character)))
[13713]2161
2162;;; src is known to be a code for which CODE-CHAR returns non-nil.
2163(define-arm-vinsn code-char->char (((dest :lisp))
2164                                   ((src :imm))
2165                                   ())
2166  (mov dest (:lsl src (:$ (- arm::charcode-shift arm::fixnum-shift))))
2167  (orr dest dest (:$ arm::subtag-character)))
2168
2169(define-arm-vinsn u32->char (((dest :lisp))
2170                             ((src :u32))
2171                             ())
2172  (mov dest (:lsl src (:$ arm::charcode-shift)))
2173  (orr dest dest (:$ arm::subtag-character)))
2174
2175;; ... Macptrs ...
2176
2177(define-arm-vinsn deref-macptr (((addr :address))
2178                                ((src :lisp))
2179                                ())
2180  (ldr addr (:@ src (:$ arm::macptr.address))))
2181
2182(define-arm-vinsn set-macptr-address (()
2183                                      ((addr :address)
2184                                       (src :lisp))
2185                                      ())
2186  (str addr (:@ src (:$ arm::macptr.address))))
2187
2188
2189(define-arm-vinsn macptr->heap (((dest :lisp))
2190                                ((address :address))
2191                                ((header :u32)))
[13741]2192  (mov header (:$ arm::subtag-macptr))
2193  (orr header header (:$ (ash arm::macptr.element-count arm::num-subtag-bits)))
2194  (sub allocptr allocptr (:$ (- arm::macptr.size arm::fulltag-misc)))
2195  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
2196  (cmp allocptr dest)
2197  (uuo-alloc-trap (:? lo))
2198  (str header (:@ allocptr (:$ arm::misc-header-offset)))
2199  (mov dest allocptr)
2200  (bic allocptr allocptr (:$ arm::fulltagmask))
[13713]2201  ;; It's not necessary to zero out the domain/type fields, since newly
2202  ;; heap-allocated memory's guaranteed to be 0-filled.
[13741]2203  (str address (:@ dest (:$ arm::macptr.address))))
[13713]2204
2205(define-arm-vinsn macptr->stack (((dest :lisp))
2206                                 ((address :address))
2207                                 ((header :u32)))
[13741]2208  (mov header (:$ arm::subtag-macptr))
2209  (orr header header (:$ (ash arm::macptr.element-count arm::num-subtag-bits)))
2210  (str header (:@! sp (:$ (- arm::macptr.size))))
2211  (mov header (:$ 0))
2212  (str header  (:@ sp (:$ (+ arm::fulltag-misc arm::macptr.domain))))
2213  (str header  (:@ sp (:$ (+ arm::fulltag-misc arm::macptr.type))))
2214  (str address (:@ sp (:$ (+ arm::fulltag-misc arm::macptr.address))))
2215  (add dest sp (:$ arm::fulltag-misc)))
[13713]2216
[13741]2217
[13713]2218 
2219(define-arm-vinsn adjust-stack-register (()
2220                                         ((reg t)
2221                                          (amount :s16const)))
2222  (add reg reg (:$ amount)))
2223
2224(define-arm-vinsn adjust-vsp (()
2225                              ((amount :s16const)))
[13741]2226  (add vsp vsp (:$ amount)))
[13713]2227
2228(define-arm-vinsn adjust-sp (()
2229                             ((amount :s16const)))
[13741]2230  (add sp sp (:$ amount)))
[13713]2231
2232;; Arithmetic on fixnums & unboxed numbers
2233
2234(define-arm-vinsn u32-lognot (((dest :u32))
2235                              ((src :u32))
2236                              ())
2237  (mvn dest src))
2238
2239(define-arm-vinsn fixnum-lognot (((dest :imm))
2240                                 ((src :imm))
2241                                 ((temp :u32)))
2242  (mvn temp src)
2243  (bic dest temp (:$ arm::fixnummask)))
2244
2245
2246(define-arm-vinsn negate-fixnum-overflow-inline (((dest :lisp))
2247                                                 ((src :imm))
2248                                                 ((unboxed :s32)
2249                                                  (header :u32)))
[13741]2250  (rsbs dest src (:$ 0))
2251  (bvc :done)
2252  (mov unboxed (:asr dest (:$ arm::fixnumshift)))
2253  (eor unboxed unboxed (:$ #xc0000000))
2254  (mov header (:$ arm::subtag-bignum))
2255  (orr header header (:$ (ash 1 arm::num-subtag-bits)))
2256  (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc)))
2257  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
2258  (cmp allocptr dest)
2259  (uuo-alloc-trap (:? lo))
2260  (str header (:@ allocptr (:$ arm::misc-header-offset)))
2261  (mov dest allocptr)
2262  (bic allocptr allocptr (:$ arm::fulltagmask))
2263  (str unboxed (:@ dest (:$ arm::misc-data-offset)))
[13713]2264  :done)
2265
2266(define-arm-vinsn negate-fixnum-overflow-ool (()
2267                                              ((src :imm))
2268                                              )
[13741]2269  (rsbs arm::arg_z src (:$ 0))
2270  (blvs .SPfix-overflow))
[13713]2271 
2272                                                 
2273                                       
2274(define-arm-vinsn negate-fixnum-no-ovf (((dest :lisp))
2275                                        ((src :imm)))
2276 
[13741]2277  (rsb dest src (:$ 0)))
[13713]2278 
2279
[13741]2280(define-arm-vinsn logior-immediate (((dest :imm))
[13713]2281                               ((src :imm)
[13741]2282                                (imm :u32const)))
2283  (orr dest src (:$ imm)))
[13713]2284
2285
[13741]2286
[13713]2287                           
2288                           
2289(define-arm-vinsn %logior2 (((dest :imm))
2290                            ((x :imm)
2291                             (y :imm))
2292                            ())
[13741]2293  (orr dest x y))
[13713]2294
[13741]2295(define-arm-vinsn logand-immediate (((dest :imm))
[13713]2296                               ((src :imm)
[13741]2297                                (imm :u32const)))
2298  (and dest src (:$ imm)))
[13713]2299
2300
2301(define-arm-vinsn %logand2 (((dest :imm))
2302                            ((x :imm)
2303                             (y :imm))
2304                            ())
2305  (and dest x y))
2306
[13741]2307(define-arm-vinsn logxor-immediate (((dest :imm))
2308                                    ((src :imm)
2309                                     (imm :u32const)))
2310  (eor dest src (:$ imm)))
2311                                   
[13713]2312
2313                               
2314
2315(define-arm-vinsn %logxor2 (((dest :imm))
2316                            ((x :imm)
2317                             (y :imm))
2318                            ())
[13741]2319  (eor dest x y))
[13713]2320
[13741]2321;;; ARM register shifts shift by the low byte of RS.
[13713]2322(define-arm-vinsn %ilsl (((dest :imm))
2323                         ((count :imm)
2324                          (src :imm))
[13741]2325                         ((temp :u32)))
2326  (mov temp (:asr count (:$ arm::fixnumshift)))
2327  (mov dest (:lsl src temp)))
[13713]2328
[13741]2329;;; Shift by a constant = -> shift by 32.  Don't do that.
[13713]2330(define-arm-vinsn %ilsl-c (((dest :imm))
2331                           ((count :u8const)
2332                            (src :imm)))
[13741]2333  ((:pred = count 0)
2334   (mov dest src))
2335  ((:not (:pred = count 0))
2336   (mov dest (:lsl src (:$ (:apply logand count 31))))))
[13713]2337
2338
2339(define-arm-vinsn %ilsr-c (((dest :imm))
2340                           ((count :u8const)
2341                            (src :imm))
[13741]2342                           ((temp :s32)))
[13713]2343  (mov temp (:lsr src (:$ count)))
[13741]2344  (bic dest temp (:$ arm::fixnummask)))
[13713]2345
2346
2347(define-arm-vinsn %iasr (((dest :imm))
2348                         ((count :imm)
2349                          (src :imm))
2350                         ((temp :s32)))
2351  (mov temp (:asr count (:$ arm::fixnumshift)))
2352  (mov temp (:asr src temp))
[13741]2353  (bic dest temp (:$ arm::fixnummask)))
[13713]2354
2355(define-arm-vinsn %iasr-c (((dest :imm))
2356                           ((count :u8const)
2357                            (src :imm))
2358                           ((temp :s32)))
[13741]2359  ((:pred = count 0)
2360   (mov dest src))
2361  ((:not (:pred = count 0))
2362   (mov temp (:asr src (:$ count)))
2363   (bic dest src (:$ arm::fixnummask))))
[13713]2364
2365(define-arm-vinsn %ilsr (((dest :imm))
2366                         ((count :imm)
2367                          (src :imm))
[13741]2368                         ((temp :s32)))
2369  (mov temp (:asr count (:$ arm::fixnumshift)))
2370  (mov temp (:lsr src temp))
2371  (bic dest temp (:$ arm::fixnummask)))
[13713]2372
[13741]2373
[13713]2374(define-arm-vinsn %ilsr-c (((dest :imm))
2375                           ((count :u8const)
2376                            (src :imm))
2377                           ((temp :s32)))
[13741]2378  ((:pred = count 0)
2379   (mov dest src))
2380  ((:not (:pred = count 0))
2381   (mov temp (:lsr src (:$ count)))
2382   (bic dest temp (:$ arm::fixnummask))))
[13713]2383
2384(define-arm-vinsn natural-shift-left (((dest :u32))
2385                                      ((src :u32)
2386                                       (count :u8const)))
[13741]2387  ((:pred = count 0)
2388   (mov dest src))
2389  ((:not (:pred = count 0))
2390   (mov dest (:lsl src (:$ count)))))
[13713]2391
2392(define-arm-vinsn natural-shift-right (((dest :u32))
2393                                       ((src :u32)
2394                                        (count :u8const)))
[13741]2395  ((:pred = count 0)
2396   (mov dest src))
2397  ((:not (:pred = count 0))
2398   (mov dest (:lsr src (:$ count)))))
[13713]2399
2400
2401(define-arm-vinsn trap-unless-simple-array-2 (()
2402                                              ((object :lisp)
2403                                               (expected-flags :u32const)
2404                                               (type-error :u8const))
2405                                              ((tag :u8)
[13741]2406                                               (flags :u32)))
2407  (and tag object (:$ arm::tagmask))
2408  (cmp tag (:$ arm::tag-misc))
2409  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
2410  (cmp tag (:$ arm::subtag-arrayH))
2411  (bne :bad-if-ne)
2412  (ldr tag (:@ object (:$ arm::arrayH.rank)))
2413  (cmp tag (:$ (ash 2 arm::fixnumshift)))
2414  (bne :bad-if-ne)
2415  (mov tag (:$ (:apply ash (:apply logand expected-flags #xff00) arm::fixnumshift)))
2416  (orr tag tag (:$ (:apply ash (:apply logand expected-flags #x00ff) arm::fixnumshift)))
2417  (ldr flags (:@ object (:$ arm::arrayH.flags)))
2418  (cmp tag flags)
2419  :bad-if-ne
2420  (uuo-error-reg-not-xtype (:? ne) object (:$ type-error)))
[13713]2421
2422(define-arm-vinsn trap-unless-simple-array-3 (()
2423                                              ((object :lisp)
[13741]2424                                               (expected-flags :u16const)
[13713]2425                                               (type-error :u8const))
2426                                              ((tag :u8)
[13741]2427                                               (flags :u32)))
2428  (and tag object (:$ arm::tagmask))
2429  (cmp tag (:$ arm::tag-misc))
2430  (ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
2431  (cmp tag (:$ arm::subtag-arrayH))
2432  (bne :bad-if-ne)
2433  (ldr tag (:@ object (:$ arm::arrayH.rank)))
2434  (cmp tag (:$ (ash 3 arm::fixnumshift)))
2435  (bne :bad-if-ne)
2436  (mov tag (:$ (:apply ash (:apply logand expected-flags #xff00) arm::fixnumshift)))
2437  (orr tag tag (:$ (:apply ash (:apply logand expected-flags #x00ff) arm::fixnumshift)))
2438  (ldr flags (:@ object (:$ arm::arrayH.flags)))
2439  (cmp tag flags)
2440  :bad-if-ne
2441  (uuo-error-reg-not-xtype (:? ne) object (:$ type-error)))
[13713]2442 
2443 
2444 
2445 
2446(define-arm-vinsn sign-extend-halfword (((dest :imm))
2447                                        ((src :imm)))
[13741]2448  (mov dest (:lsl src (:$ (- 16 arm::fixnumshift))))
2449  (mov dest (:asr dest (:$ (- 16 arm::fixnumshift)))))
[13713]2450
2451
2452                           
2453
2454(define-arm-vinsn fixnum-add (((dest t))
2455                              ((x t)
2456                               (y t)))
2457  (add dest x y))
2458
2459
2460(define-arm-vinsn fixnum-add-overflow-ool (()
2461                                           ((x :imm)
2462                                            (y :imm))
[13741]2463                                           ())
2464  (adds arm::arg_z x y)
2465  (blvs .SPfix-overflow))
[13713]2466
2467(define-arm-vinsn fixnum-add-overflow-inline (((dest :lisp))
2468                                              ((x :imm)
2469                                               (y :imm))
[13741]2470                                              ((unboxed :s32)
[13713]2471                                               (header :u32)))
[13741]2472  (adds dest x y)
2473  (bvc :done)
2474  (mov unboxed (:asr dest (:$ arm::fixnumshift)))
2475  (mov header (:$ arm::subtag-bignum))
2476  (orr header header (:$ (ash 1 arm::num-subtag-bits)))
2477  (eor unboxed unboxed (:$ #xc0000000))
2478  (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc)))
2479  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
2480  (cmp allocptr dest)
2481  (uuo-alloc-trap (:? lo))
2482  (str header (:@ allocptr (:$ arm::misc-header-offset)))
2483  (mov dest allocptr)
2484  (bic allocptr allocptr (:$ arm::fulltagmask))
2485  (str unboxed (:@ dest (:$ arm::misc-data-offset)))
[13713]2486  :done)
2487
2488(define-arm-vinsn fixnum-add-overflow-inline-skip (((dest :lisp))
2489                                                   ((x :imm)
2490                                                    (y :imm)
2491                                                    (target :label))
[13741]2492                                                   ((unboxed :s32)
[13713]2493                                                    (header :u32)))
[13741]2494  (adds dest x y)
2495  (bvc target)
2496  (mov unboxed (:asr dest (:$ arm::fixnumshift)))
2497  (mov header (:$ arm::subtag-bignum))
2498  (orr header header (:$ (ash 1 arm::num-subtag-bits)))
2499  (eor unboxed unboxed (:$ #xc0000000))
2500  (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc)))
2501  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocptr)))
2502  (cmp allocptr dest)
2503  (uuo-alloc-trap (:? lo))
2504  (str header (:@ allocptr (:$ arm::misc-header-offset)))
2505  (mov dest allocptr)
2506  (bic allocptr allocptr (:$ arm::fulltagmask))
2507  (str unboxed (:@ dest (:$ arm::misc-data-offset)))
[13713]2508  (b target))
2509 
2510
2511 
2512
2513;;;  (setq dest (- x y))
2514(define-arm-vinsn fixnum-sub (((dest t))
2515                              ((x t)
2516                               (y t)))
[13741]2517  (sub dest x y))
[13713]2518
2519(define-arm-vinsn fixnum-sub-from-constant (((dest :imm))
2520                                            ((x :s16const)
2521                                             (y :imm)))
[13741]2522  (rsb dest y (:$ (:apply ash x arm::fixnumshift))))
[13713]2523
2524
2525
2526
2527(define-arm-vinsn fixnum-sub-overflow-ool (()
2528                                           ((x :imm)
2529                                            (y :imm)))
[13741]2530  (subs arm::arg_z x y)
2531  (blvs .SPfix-overflow))
[13713]2532
2533(define-arm-vinsn fixnum-sub-overflow-inline (((dest :lisp))
2534                                              ((x :imm)
2535                                               (y :imm))
2536                                              ((cr0 (:crf 0))
2537                                               (unboxed :s32)
2538                                               (header :u32)))
[13741]2539  (subs dest x y)
2540  (bvc :done)
2541  (mov unboxed (:asr dest (:$ arm::fixnumshift)))
2542  (mov header (:$ arm::subtag-bignum))
2543  (orr header header (:$ (ash 1 arm::num-subtag-bits)))
2544  (eor unboxed unboxed (:$ #xc0000000))
2545  (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc)))
2546  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
2547  (cmp allocptr dest)
2548  (uuo-alloc-trap (:? lo))
2549  (str header (:@ allocptr (:$ arm::misc-header-offset)))
2550  (mov dest allocptr)
2551  (bic allocptr allocptr (:$ arm::fulltagmask))
2552  (str unboxed (:@ dest (:$ arm::misc-data-offset)))
[13713]2553  :done)
2554
2555(define-arm-vinsn fixnum-sub-overflow-inline-skip (((dest :lisp))
2556                                                   ((x :imm)
2557                                                    (y :imm)
2558                                                    (target :label))
[13741]2559                                                   ((unboxed :s32)
[13713]2560                                                    (header :u32)))
[13741]2561  (subs dest x y)
2562  (bvc target)
[13751]2563  (mov unboxed (:asr dest (:$ arm::fixnumshift)))
[13741]2564  (mov header (:$ arm::subtag-bignum))
2565  (orr header header (:$ (ash 1 arm::num-subtag-bits)))
2566  (eor unboxed unboxed (:$ #xc0000000))
2567  (sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc)))
2568  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
2569  (cmp allocptr dest)
2570  (uuo-alloc-trap (:? lo))
2571  (str header (:@ allocptr (:$ arm::misc-header-offset)))
2572  (mov dest allocptr)
2573  (bic allocptr allocptr (:$ arm::fulltagmask))
2574  (str unboxed (:@ dest (:$ arm::misc-data-offset)))
[13713]2575  (b target))
2576
2577;;; This is, of course, also "subtract-immediate."
2578(define-arm-vinsn add-immediate (((dest t))
2579                                 ((src t)
[13741]2580                                  (imm :s32const)))
2581  (add dest src (:$ imm)))
[13713]2582
2583(define-arm-vinsn multiply-fixnums (((dest :imm))
2584                                    ((a :imm)
2585                                     (b :imm))
2586                                    ((unboxed :s32)))
[13741]2587  (mov unboxed (:asr b (:$ arm::fixnumshift)))
2588  (mul dest a unboxed))
[13713]2589
2590
[13741]2591
[13713]2592;;; Mask out the code field of a base character; the result
2593;;; should be EXACTLY = to subtag-base-char
2594(define-arm-vinsn mask-base-char (((dest :u32))
2595                                  ((src :imm)))
[13741]2596  (and dest src (:$ arm::subtag-mask)))
[13713]2597
2598;;; Set dest (of type :s32!) to 0 iff VAL is an istruct of type TYPE
2599(define-arm-vinsn istruct-typep (((dest :s32))
2600                                 ((val :lisp)
2601                                  (type :lisp))
[13741]2602                                 ((temp :lisp)))
2603  (and dest val (:$ arm::tagmask))
2604  (cmp dest (:$ arm::tag-misc))
2605  (ldrbeq dest (:@ val (:$ arm::misc-subtag-offset)))
2606  (cmp dest (:$ arm::subtag-istruct))
2607  (movne dest (:$ -1))
2608  (ldreq temp (:@ val (:$ arm::misc-data-offset)))
2609  (subeq dest type temp))
[13713]2610 
2611 
2612;; Boundp, fboundp stuff.
2613(define-arm-vinsn (ref-symbol-value :call :subprim-call)
2614    (((val :lisp))
2615     ((sym (:lisp (:ne val)))))
2616  (bl .SPspecrefcheck))
2617
2618(define-arm-vinsn ref-symbol-value-inline (((dest :lisp))
2619                                           ((src (:lisp (:ne dest))))
2620                                           ((table :imm)
2621                                            (idx :imm)))
[13741]2622  (ldr idx (:@ src (:$ arm::symbol.binding-index)))
2623  (ldr table (:@ rcontext (:$ arm::tcr.tlb-limit)))
2624  (cmp idx table)
2625  (ldr table (:@ rcontext (:$ arm::tcr.tlb-pointer)))
2626  (movhs idx (:$ 0))
2627  (ldr dest (:@ table idx))
2628  (cmp dest (:$ arm::subtag-no-thread-local-binding))
2629  (ldreq dest (:@ src (:$ arm::symbol.vcell)))
2630  (cmp dest (:$ arm::unbound-marker))
2631  (uuo-error-unbound (:? eq) src))
[13713]2632
2633(define-arm-vinsn (%ref-symbol-value :call :subprim-call)
2634    (((val :lisp))
2635     ((sym (:lisp (:ne val)))))
2636  (bl .SPspecref))
2637
2638(define-arm-vinsn %ref-symbol-value-inline (((dest :lisp))
2639                                            ((src (:lisp (:ne dest))))
2640                                            ((table :imm)
2641                                             (idx :imm)))
[13741]2642  (ldr idx (:@ src (:$ arm::symbol.binding-index)))
2643  (ldr table (:@ rcontext (:$ arm::tcr.tlb-limit)))
2644  (cmp idx table)
2645  (ldr table (:@ rcontext (:$ arm::tcr.tlb-pointer)))
2646  (movhs idx (:$ 0))
2647  (ldr dest (:@ table idx))
2648  (cmp dest (:$ arm::subtag-no-thread-local-binding))
2649  (ldreq dest (:@ src (:$ arm::symbol.vcell))))
[13713]2650
2651(define-arm-vinsn (setq-special :call :subprim-call)
2652    (()
2653     ((sym :lisp)
2654      (val :lisp)))
2655  (bl .SPspecset))
2656
2657
2658(define-arm-vinsn symbol-function (((val :lisp))
2659                                   ((sym (:lisp (:ne val))))
2660                                   ((crf :crf)
2661                                    (tag :u32)))
[13741]2662  (ldr val (:@ sym (:$ arm::symbol.fcell)))
2663  (and tag val (:$ arm::tagmask))
2664  (cmp tag (:$ arm::tag-misc))
2665  (ldrbeq tag (:@ val (:$ arm::misc-subtag-offset)))
2666  (cmp tag (:$ arm::subtag-function))
2667  (uuo-error-udf (:? ne) sym))
[13713]2668
2669(define-arm-vinsn (temp-push-unboxed-word :push :word :sp)
2670    (()
2671     ((w :u32))
2672     ((header :u32)))
2673  (mov header (:$ arm::subtag-u32-vector))
2674  (orr header header (:$ (ash 1 arm::num-subtag-bits)))
2675  (str header (:@ sp (:$ (- arm::dnode-size))))
[13741]2676  (str w (:@ sp (:$ 4))))
[13713]2677
2678(define-arm-vinsn (temp-pop-unboxed-word :pop :word :sp)
2679    (((w :u32))
2680     ())
2681  (ldr w (:@ sp (:$ 4)))
2682  (add sp sp (:$ arm::dnode-size)))
2683
[13741]2684#+notyet
[13713]2685(define-arm-vinsn (temp-push-double-float :push :doubleword :sp)
2686    (()
2687     ((d :double-float))
2688     ((header :u32)))
2689  (mov header (:$ arm::subtag-double-float))
2690  (orr header header (:$ (ash arm::double-float.element-count arm::num-subtag-bits)))
2691  (str header (:@! sp (:$ (- (* 2 arm::dnode-size)))))
2692  (fstd d (:@ sp (:$ 8))))
2693
[13741]2694#+notyet
[13713]2695(define-arm-vinsn (temp-pop-double-float :pop :doubleword :sp)
2696    (()
2697     ((d :double-float)))
2698  (fldd d (:@ sp (:$ 8)))
2699  (add sp sp (:$ (* 2 arm::dnode-size))))
2700
[13741]2701#+notyet
[13713]2702(define-arm-vinsn (temp-push-single-float :push :word :tsp)
2703    (()
2704     ((s :single-float))
2705     ((header :u32)))
2706  (mov header (:$ arm::subtag-single-float))
2707  (orr header header (:$ (ash arm::single-float.element-count arm::num-subtag-bits)))
2708  (str header (:@! sp (:$ (- arm::dnode-size))))
2709  (fsts s (:@ sp (:$ 4))))
2710
[13741]2711#+notyet
[13713]2712(define-arm-vinsn (temp-pop-single-float :pop :word :sp)
2713    (()
2714     ((s :single-float)))
2715  (flds s (:@ sp 4))
2716  (add sp sp (:$ arm::dnode-size)))
2717
2718
2719
2720(define-arm-vinsn %current-frame-ptr (((dest :imm))
2721                                      ())
2722  (mov dest arm::sp))
2723
2724(define-arm-vinsn %current-tcr (((dest :imm))
2725                                ())
[13741]2726  (mov dest rcontext))
[13713]2727
2728(define-arm-vinsn (dpayback :call :subprim-call) (()
2729                                                  ((n :s16const))
2730                                                  ((temp (:u32 #.arm::imm0))))
2731  ((:pred > n 1)
2732   (mov temp (:$ n))
2733   (bl .SPunbind-n))
2734  ((:pred = n 1)
2735   (bl .SPunbind)))
2736
2737(define-arm-vinsn zero-double-float-register (((dest :double-float))
[13741]2738                                              ()
2739                                              ((temp t)))
2740  (mov temp (:$ 0))
2741  (fmsr dest temp))
[13713]2742
2743(define-arm-vinsn zero-single-float-register (((dest :single-float))
[13741]2744                                              ()
2745                                              ((temp t)))
2746  (mov temp (:$ 0))
2747  (fmdrr dest temp temp))
[13713]2748
2749(define-arm-vinsn load-double-float-constant (((dest :double-float))
2750                                              ((high :u32)
2751                                               (low :u32)))
2752  (fmdrr dest low high))
2753
2754(define-arm-vinsn load-single-float-constant    (((dest :single-float))
2755                                                 ((src t)))
2756  (fmsr dest src))
2757
2758(define-arm-vinsn load-indexed-node (((node :lisp))
2759                                     ((base :lisp)
2760                                      (offset :s16const)))
2761  (ldr node (:@ base (:$ offset))))
2762
2763(define-arm-vinsn check-exact-nargs (()
2764                                     ((n :u16const)))
2765  (cmp nargs (:$ (:apply ash n 2)))
[13741]2766  (uuo-error-wrong-nargs (:? ne)))
[13713]2767
2768(define-arm-vinsn check-min-nargs (()
2769                                   ((min :u16const)))
2770  (cmp nargs (:$ (:apply ash min 2)))
[13741]2771  (uuo-error-wrong-nargs (:? lo)))
[13713]2772
2773
2774(define-arm-vinsn check-max-nargs (()
2775                                   ((max :u16const)))
2776  (cmp nargs (:$ (:apply ash max 2)))
[13741]2777  (uuo-error-wrong-nargs (:? hi)))
[13713]2778
2779;;; Save context and establish FN.  The current VSP is the the
2780;;; same as the caller's, e.g., no arguments were vpushed.
2781(define-arm-vinsn save-lisp-context-vsp (()
2782                                         ()
2783                                         ((imm :u32)))
2784  (mov imm (:$ arm::lisp-frame-marker))
[13741]2785  (stmdb (:! sp) (imm vsp fn lr))
2786  (mov fn nfn))
[13713]2787
2788
2789
2790(define-arm-vinsn save-lisp-context-offset (()
2791                                            ((nbytes-vpushed :u16const))
[13751]2792                                            ((imm (:u32 #.arm::imm1))))
[13713]2793  (add imm vsp (:$ nbytes-vpushed))
2794  (mov imm0 (:$ arm::lisp-frame-marker))
[13741]2795  (stmdb (:! sp) (imm0 imm fn lr))
2796  (mov fn nfn))
[13713]2797
[13751]2798(define-arm-vinsn save-lisp-context-variable (()
2799                                              ()
2800                                              ((imm (:u32 #.arm::imm1))))
2801  (subs imm nargs (:$ (ash $numarmargregs arm::word-shift)))
2802  (movmi imm (:$ 0))
2803  (add imm imm vsp)
2804  (mov imm0 (:$ arm::lisp-frame-marker))
2805  (stmdb (:! sp) (imm0 imm fn lr))
2806  (mov fn nfn)) 
[13713]2807
2808
[13751]2809
[13713]2810#+later
2811(define-arm-vinsn save-lisp-context-lexpr (()
2812                                           ()
2813                                           ((imm :u32)))
2814  (stwu arm::sp (- arm::lisp-frame.size) arm::sp)
[13741]2815  (str arm::rzero (:@ arm::sp (:$ arm::lisp-frame.savefn)))
2816  (str arm::loc-pc (:@ arm::sp (:$ arm::lisp-frame.savelr)))
2817  (str vsp (:@ arm::sp (:$ arm::lisp-frame.savevsp)))
[13713]2818  (mr arm::fn arm::nfn)
2819  ;; Do a stack-probe ...
[13741]2820  (ldr imm (:@ rcontext (:$ arm::tcr.cs-limit)))
[13713]2821  (twllt arm::sp imm))
2822 
2823(define-arm-vinsn save-cleanup-context (()
2824                                        ())
2825  (mov temp2 (:$ 0))
2826  (mov imm0 (:$ arm::lisp-frame-marker)) 
2827  (stmdb (:! sp) (imm0 vsp temp2 lr)))
2828
2829
2830;; Vpush the argument registers.  We got at least "min-fixed" args;
2831;; that knowledge may help us generate better code.
2832#+later
2833(define-arm-vinsn (save-lexpr-argregs :call :subprim-call)
2834    (()
2835     ((min-fixed :u16const))
2836     ((crfx :crf)
2837      (crfy :crf)
2838      (entry-vsp (:u32 #.arm::imm0))
2839      (arg-temp :u32)))
2840  ((:pred >= min-fixed $numarmargregs)
[13741]2841   (stwu arm::arg_x -4 vsp)   
2842   (stwu arm::arg_y -4 vsp)   
2843   (stwu arm::arg_z -4 vsp))
[13713]2844  ((:pred = min-fixed 2)                ; at least 2 args
2845   (cmplwi crfx nargs (ash 2 arm::word-shift))
2846   (beq crfx :yz2)                      ; skip arg_x if exactly 2
[13741]2847   (stwu arm::arg_x -4 vsp)
[13713]2848   :yz2
[13741]2849   (stwu arm::arg_y -4 vsp)
2850   (stwu arm::arg_z -4 vsp))
[13713]2851  ((:pred = min-fixed 1)                ; at least one arg
2852   (cmplwi crfx nargs (ash 2 arm::word-shift))
2853   (blt crfx :z1)                       ; branch if exactly one
2854   (beq crfx :yz1)                      ; branch if exactly two
[13741]2855   (stwu arm::arg_x -4 vsp)
[13713]2856   :yz1
[13741]2857   (stwu arm::arg_y -4 vsp)   
[13713]2858   :z1
[13741]2859   (stwu arm::arg_z -4 vsp))
[13713]2860  ((:pred = min-fixed 0)
2861   (cmplwi crfx nargs (ash 2 arm::word-shift))
2862   (cmplwi crfy nargs 0)
2863   (beq crfx :yz0)                      ; exactly two
2864   (beq crfy :none)                     ; exactly zero
2865   (blt crfx :z0)                       ; one
2866                                        ; Three or more ...
[13741]2867   (stwu arm::arg_x -4 vsp)
[13713]2868   :yz0
[13741]2869   (stwu arm::arg_y -4 vsp)
[13713]2870   :z0
[13741]2871   (stwu arm::arg_z -4 vsp)
[13713]2872   :none
2873   )
2874  ((:pred = min-fixed 0)
[13741]2875   (stwu nargs -4 vsp))
[13713]2876  ((:not (:pred = min-fixed 0))
2877   (subi arg-temp nargs (:apply ash min-fixed arm::word-shift))
[13741]2878   (stwu arg-temp -4 vsp))
2879  (add entry-vsp vsp nargs)
[13713]2880  (la entry-vsp 4 entry-vsp)
2881  (bl .SPlexpr-entry))
2882
2883
2884(define-arm-vinsn (jump-return-pc :jumpLR)
2885    (()
2886     ())
2887  (bx lr))
2888
2889(define-arm-vinsn (restore-full-lisp-context :lispcontext :pop :csp :lrRestore)
2890    (()
2891     ())
2892  (ldmia (:! sp) (imm0 vsp fn lr)))
2893
2894
2895
2896
2897
2898(define-arm-vinsn (popj :lispcontext :pop :csp :lrRestore :jumpLR)
2899    (() 
2900     ())
2901  (ldmia (:! sp) (imm0 vsp fn pc)))
2902
2903;;; Exiting from an UNWIND-PROTECT cleanup is similar to
2904;;; (and a little simpler than) returning from a function.
2905(define-arm-vinsn restore-cleanup-context (()
2906                                           ())
[13741]2907  (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
[13713]2908  (add sp sp (:$ arm::lisp-frame.size)))
2909
2910
2911
2912(define-arm-vinsn default-1-arg (()
2913                                 ((min :u16const)))
2914  (cmp nargs (:$ (:apply ash min 2)))
2915  (bne :done)
2916  ((:pred >= min 3)
[13741]2917   (str arg_x (:@! vsp (:$ (- arm::node-size)))))
[13713]2918  ((:pred >= min 2)
2919   (mov arg_x arg_y))
2920  ((:pred >= min 1)
2921   (mov arg_y arg_z))
[13741]2922  (mov arm::arg_z (:$ arm::nil-value))
[13713]2923  :done)
2924
2925(define-arm-vinsn default-2-args (()
2926                                  ((min :u16const)))
[13741]2927  (cmp nargs (:$ (:apply ash (:apply 1+ min) 2)))
[13713]2928  (bgt :done)
2929  (beq :one)
2930  ;; We got "min" args; arg_y & arg_z default to nil
2931  ((:pred >= min 3)
2932   (str arg_x (:@! vsp (:$ (- arm::node-size)))))   
2933  ((:pred >= min 2)
2934   (str arg_y (:@! vsp (:$ (- arm::node-size)))))
2935  ((:pred >= min 1)
2936   (mov arg_x (:$ arm::nil-value)))
2937  (mov arg_y (:$ arm::nil-value))
2938  (b :last)
2939  :one
2940  ;; We got min+1 args: arg_y was supplied, arg_z defaults to nil.
2941  ((:pred >= min 2)
2942   (str arg_x (:@! vsp (:$ (- arm::node-size)))))
2943  ((:pred >= min 1)
[13741]2944   (mov arg_x arg_y))
2945  (mov arm::arg_y arm::arg_z)
[13713]2946  :last
2947  (mov arg_z (:$ arm::nil-value))
2948  :done)
2949
2950(define-arm-vinsn default-3-args (()
2951                                  ((min :u16const)))
2952  (cmp nargs (:$ (:apply ash min 2)))
2953  (beq :none)
2954  (cmp nargs (:$ (:apply ash (:apply + 2 min) 2)))
2955
2956  (bgt :done)
2957  (beq :two)
2958  ;; The first (of three) &optional args was supplied.
2959  ((:pred >= min 2)
2960   (str arg_x (:@! vsp (:$ (- arm::node-size)))))
2961  ((:pred >= min 1)
2962   (str arg_y (:@! vsp (:$ (- arm::node-size)))))
2963  (mov arg_x arg_z)
2964  (b :last-2)
2965  :two
2966  ;; The first two (of three) &optional args were supplied.
2967  ((:pred >= min 1)
2968   (str arg_x (:@! vsp (:$ (- arm::node-size)))))
2969  (mov arg_x arg_y)
2970  (mov arg_y arg_z)
2971  (b :last-1)
2972  ;; None of the three &optional args was provided.
2973  :none<