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

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

Conditionalize for #-target-8-bit-chars.

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