source: trunk/source/compiler/PPC/PPC32/ppc32-vinsns.lisp @ 10365

Last change on this file since 10365 was 10365, checked in by gb, 11 years ago

Change fixnum->char (to exclude #xffff,#xfffe); add char-code->char.

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