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

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

arm-constants.h, thread_manager.c: tcr.last_lisp_frame is just a natural.

arm-exceptions.c: maintain tcr.last_lisp_frame when entering/exiting
signal handlers. Signal thread interrupts by calling back to cmain
with signal 0.

arm-spentry.s: add an entrypoint that calls to undefined functions
wind up at. Dont' really need .SPtfuncallvsp. Check for pending
interrupts on ffcall return. Box the unboxed callback index in
.SPeabi_callback, don't unbox it even more.

arm-uuo.s: closer to lisp's idea of UUO encoding, but still not there.

xfasload.lisp: build the undefined function object differently.

arm-asm.lisp, arm-disassemble.lisp: uuo-slot-unbound encodes 3 registers

arm-lapmacros.lisp: define SET-GLOBAL; needs an extra temp reg.

arm-vinsns.lisp: scale-1bit-misc-index needs another shift. 3-operand
slot-unbound UUO. EEP-unresolved UUO operand order. No more .SPtfuncallvsp.
Make sure that nargs doesn't get clobbered in UNBIND-INTERRUPT-LEVEL-INLINE.

arm-array.lisp: in @string case of %init-misc, shift value, not tag.

arm-misc.lisp: add PENDING-USER-INTERRUPT, %%SAVE-APPLICATION.

arm-callback-support.lisp, arm-error-signal.lisp,
arm-trap-support.lisp,l1-boot-3.lisp: try to get basic stuff working
well enough to enable callbacks. Enable callbacks.

arm-backtrace.lisp: a little bit of platform-specific code and some
code from the PPC port, so that backtrace sort of works.

Status: can save an image (and it's more-or-less worth doing so.)
Crashes (somewhere in the type-system) compiling db-io.lisp, so I
don't yet know what undefined things would be warned about.

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