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

Last change on this file since 5046 was 5046, checked in by gb, 14 years ago

%unbox-u8, u8-vref stuff.

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