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

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

A lot of this is nominally converted (from the PPC32 version); still
some to be done, but we need real vinsns to get the vinsn->codegen
mechanisms working.

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