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

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

%FIXNUM-{REF|SET}-DOUBLE-FLOAT support in PPC backends.

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