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

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

arm2.lisp: 32-bit case of ARM2-VREF1 wasn't parenthesized right, so we did both

the constant- and variable-index case.

arm-vinsns.lisp: lots of bugs in SAVE-LEXPR-ARGREGS
arm-pred.lisp: in EQUAL, compare to NIL, not 'NUL.
l1-clos-boot.lisp: more ARM conditionalization.
arm-spentry.s: use the right register in _SPbind.

Implement _SPnthrowvalues, fix in _SPnthrow1value.
Try to add uuo_debug_trap() to subprims that still aren't implemented.

Currently crashes in code called by ENSURE-METHOD, possibly on the first
DEFMETHOD.

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