source: trunk/source/compiler/PPC/ppc-lapmacros.lisp @ 13067

Last change on this file since 13067 was 13067, checked in by rme, 10 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 34.0 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(eval-when (:compile-toplevel :load-toplevel :execute)
20  (require "PPC-LAP"))
21 
22
23(defppclapmacro clrrri (&rest args)
24  (target-arch-case
25   (:ppc32 `(clrrwi ,@args))
26   (:ppc64 `(clrrdi ,@args))))
27
28(defppclapmacro clrlri (&rest args)
29  (target-arch-case
30   (:ppc32 `(clrlwi ,@args))
31   (:ppc64 `(clrldi ,@args))))
32
33(defppclapmacro clrlri. (&rest args)
34  (target-arch-case
35   (:ppc32 `(clrlwi. ,@args))
36   (:ppc64 `(clrldi. ,@args))))
37
38(defppclapmacro ldr (&rest args)
39  (target-arch-case
40   (:ppc32 `(lwz ,@args))
41   (:ppc64 `(ld ,@args))))
42
43(defppclapmacro ldrx (&rest args)
44  (target-arch-case
45   (:ppc32 `(lwzx ,@args))
46   (:ppc64 `(ldx ,@args))))
47
48(defppclapmacro ldru (&rest args)
49  (target-arch-case
50   (:ppc32 `(lwzu ,@args))
51   (:ppc64 `(ldu ,@args))))
52
53(defppclapmacro str (&rest args)
54  (target-arch-case
55   (:ppc32 `(stw ,@args))
56   (:ppc64 `(std ,@args))))
57
58(defppclapmacro strx (&rest args)
59  (target-arch-case
60   (:ppc32 `(stwx ,@args))
61   (:ppc64 `(stdx ,@args))))
62
63(defppclapmacro stru (&rest args)
64  (target-arch-case
65   (:ppc32 `(stwu ,@args))
66   (:ppc64 `(stdu ,@args))))
67
68(defppclapmacro strux (&rest args)
69  (target-arch-case
70   (:ppc32 `(stwux ,@args))
71   (:ppc64 `(stdux ,@args))))
72
73(defppclapmacro lrarx (&rest args)
74  (target-arch-case
75   (:ppc32 `(lwarx ,@args))
76   (:ppc64 `(ldarx ,@args))))
77
78(defppclapmacro strcx. (&rest args)
79  (target-arch-case
80   (:ppc32 `(stwcx. ,@args))
81   (:ppc64 `(stdcx. ,@args))))
82 
83(defppclapmacro cmpr (&rest args)
84  (target-arch-case
85   (:ppc32 `(cmpw ,@args))
86   (:ppc64 `(cmpd ,@args))))
87
88(defppclapmacro cmpri (&rest args)
89  (target-arch-case
90   (:ppc32 `(cmpwi ,@args))
91   (:ppc64 `(cmpdi ,@args))))
92
93(defppclapmacro cmplr (&rest args)
94  (target-arch-case
95   (:ppc32 `(cmplw ,@args))
96   (:ppc64 `(cmpld ,@args))))
97
98(defppclapmacro cmplri (&rest args)
99  (target-arch-case
100   (:ppc32 `(cmplwi ,@args))
101   (:ppc64 `(cmpldi ,@args))))
102
103(defppclapmacro trlge (&rest args)
104  (target-arch-case
105   (:ppc32 `(twlge ,@args))
106   (:ppc64 `(tdlge ,@args))))
107
108(defppclapmacro trlgei (&rest args)
109  (target-arch-case
110   (:ppc32 `(twlgei ,@args))
111   (:ppc64 `(tdlgei ,@args))))
112
113(defppclapmacro trllt (&rest args)
114  (target-arch-case
115   (:ppc32 `(twllt ,@args))
116   (:ppc64 `(tdllt ,@args))))
117
118(defppclapmacro trllti (&rest args)
119  (target-arch-case
120   (:ppc32 `(twllti ,@args))
121   (:ppc64 `(tdllti ,@args))))
122
123(defppclapmacro trlgti (&rest args)
124  (target-arch-case
125   (:ppc32 `(twlgti ,@args))
126   (:ppc64 `(tdlgti ,@args))))
127
128(defppclapmacro trlti (&rest args)
129  (target-arch-case
130   (:ppc32 `(twlti ,@args))
131   (:ppc64 `(tdlti ,@args))))
132
133(defppclapmacro trlle (&rest args)
134  (target-arch-case
135   (:ppc32 `(twlle ,@args))
136   (:ppc64 `(tdlle ,@args))))
137
138(defppclapmacro treqi (&rest args)
139  (target-arch-case
140   (:ppc32 `(tweqi ,@args))
141   (:ppc64 `(tdeqi ,@args))))
142
143(defppclapmacro trnei (&rest args)
144  (target-arch-case
145   (:ppc32 `(twnei ,@args))
146   (:ppc64 `(tdnei ,@args))))
147
148(defppclapmacro trgti (&rest args)
149  (target-arch-case
150   (:ppc32 `(twgti ,@args))
151   (:ppc64 `(tdgti ,@args))))
152
153
154(defppclapmacro srari (&rest args)
155  (target-arch-case
156   (:ppc32 `(srawi ,@args))
157   (:ppc64 `(sradi ,@args))))
158
159(defppclapmacro srar (&rest args)
160  (target-arch-case
161   (:ppc32 `(sraw ,@args))
162   (:ppc64 `(srad ,@args))))
163
164(defppclapmacro slr (&rest args)
165  (target-arch-case
166   (:ppc32 `(slw ,@args))
167   (:ppc64 `(sld ,@args))))
168
169(defppclapmacro srri (&rest args)
170  (target-arch-case
171   (:ppc32 `(srwi ,@args))
172   (:ppc64 `(srdi ,@args))))
173
174(defppclapmacro slri (&rest args)
175  (target-arch-case
176   (:ppc32 `(slwi ,@args))
177   (:ppc64 `(sldi ,@args))))
178
179(defppclapmacro slri. (&rest args)
180  (target-arch-case
181   (:ppc32 `(slwi. ,@args))
182   (:ppc64 `(sldi. ,@args))))
183
184(defppclapmacro srr (&rest args)
185  (target-arch-case
186   (:ppc32 `(srw ,@args))
187   (:ppc64 `(srd ,@args))))
188
189(defppclapmacro bkpt ()
190  `(tweq rzero rzero))
191
192(defppclapmacro dbg (&optional save-lr?)
193  (if save-lr?
194    `(progn
195       (mflr loc-pc)
196       (str imm0 -40 sp) ; better than clobbering imm0
197       (bla .SPbreakpoint)
198       (ldr imm0 -40 sp)
199       (mtlr loc-pc))
200    `(bla .SPbreakpoint)))
201
202(defppclapmacro lwi (dest n)
203  (setq n (logand n #xffffffff))
204  (let* ((mask #xffff8000)
205         (masked (logand n mask))
206         (high (ash n -16))
207         (low (logand #xffff n)))
208    (if (or (= 0 masked) (= mask masked))
209      `(li ,dest ,low)
210      (if (= low 0)
211        `(lis ,dest ,high)
212        `(progn
213           (lis ,dest ,high)
214           (ori ,dest ,dest ,low))))))
215
216(defppclapmacro set-nargs (n)
217  (check-type n (unsigned-byte 13))
218  `(li nargs ',n))
219
220(defppclapmacro check-nargs (min &optional (max min))
221  (if (eq max min)
222    `(trnei nargs ',min)
223    (if (null max)
224      (unless (= min 0)
225        `(trllti nargs ',min))
226      (if (= min 0)
227        `(trlgti nargs ',max)
228        `(progn
229           (trllti nargs ',min)
230           (trlgti nargs ',max))))))
231
232;; Event-polling involves checking to see if the value of the current
233;; thread's interrupt-level is > 0.  For now, use nargs; this may
234;; change to "any register BUT nargs".  (Note that most number-of-args
235;; traps use unsigned comparisons.)
236(defppclapmacro event-poll ()
237  (target-arch-case
238   (:ppc32
239    '(progn
240      (lwz nargs ppc32::tcr.tlb-pointer ppc32::rcontext)
241      (lwz nargs ppc32::interrupt-level-binding-index nargs)
242      (twgti nargs 0)))
243   (:ppc64
244    '(progn     
245      (ld nargs ppc64::tcr.tlb-pointer ppc64::rcontext)
246      (ld nargs ppc64::interrupt-level-binding-index nargs)
247      (tdgti nargs 0)))))
248   
249
250;;; There's no "else"; learn to say "(progn ...)".
251;;; Note also that the condition is a CR bit specification (or a "negated" one).
252;;; Whatever affected that bit (hopefully) happened earlier in the pipeline.
253(defppclapmacro if (test then &optional (else nil else-p))
254  (multiple-value-bind (bitform negated) (ppc-lap-parse-test test)
255    (let* ((false-label (gensym)))
256      (if (not else-p)
257      `(progn
258         (,(if negated 'bt 'bf) ,bitform ,false-label)
259         ,then
260         ,false-label)
261      (let* ((cont-label (gensym)))
262        `(progn
263          (,(if negated 'bt 'bf) ,bitform ,false-label)
264          ,then
265          (b ,cont-label)
266          ,false-label
267          ,else
268          ,cont-label))))))
269
270(defppclapmacro save-pc ()
271  `(mflr loc-pc))
272
273;;; This needs to be done if we aren't a leaf function (e.g., if we
274;;; clobber our return address or need to reference any constants.  Note
275;;; that it's not atomic wrt a preemptive scheduler, but we need to
276;;; pretend that it will be.)  The VSP to be saved is the value of the
277;;; VSP before any of this function's arguments were vpushed by its
278;;; caller; that's not the same as the VSP register if any non-register
279;;; arguments were received, but is usually easy to compute.
280
281(defppclapmacro save-lisp-context (&optional (vsp 'vsp) (save-pc t))
282  (target-arch-case
283   (:ppc32
284    `(progn
285      ,@(if save-pc 
286            '((save-pc)))
287      (stwu sp (- ppc32::lisp-frame.size) sp)
288      (stw fn ppc32::lisp-frame.savefn sp)
289      (stw loc-pc ppc32::lisp-frame.savelr sp)
290      (stw ,vsp ppc32::lisp-frame.savevsp sp)
291      (mr fn nfn)))
292   (:ppc64
293    `(progn
294      ,@(if save-pc 
295            '((save-pc)))
296      (stdu sp (- ppc64::lisp-frame.size) sp)
297      (std fn ppc64::lisp-frame.savefn sp)
298      (std loc-pc ppc64::lisp-frame.savelr sp)
299      (std ,vsp ppc64::lisp-frame.savevsp sp)
300      (mr fn nfn)))))
301
302;;; There are a few cases to deal with when restoring: whether or not
303;;; to restore the vsp, whether we need to saved LR back in the LR or
304;;; whether it only needs to get as far as loc-pc, etc.  This fully
305;;; restores everything (letting the caller specify some register
306;;; other than the VSP, if that's useful.)  Note that, since FN gets
307;;; restored, it's no longer possible to use it to address the current
308;;; function's constants.
309(defppclapmacro restore-full-lisp-context (&optional (vsp 'vsp))
310  (target-arch-case
311   (:ppc32
312    `(progn
313      (lwz loc-pc ppc32::lisp-frame.savelr sp)
314      (lwz ,vsp ppc32::lisp-frame.savevsp sp)
315      (mtlr loc-pc)
316      (lwz fn ppc32::lisp-frame.savefn sp)
317      (la sp ppc32::lisp-frame.size sp)))
318   (:ppc64
319    `(progn
320      (ld loc-pc ppc64::lisp-frame.savelr sp)
321      (ld ,vsp ppc64::lisp-frame.savevsp sp)
322      (mtlr loc-pc)
323      (ld fn ppc64::lisp-frame.savefn sp)
324      (la sp ppc64::lisp-frame.size sp)))))
325
326(defppclapmacro restore-pc ()
327  `(mtlr loc-pc))
328
329(defppclapmacro push (src stack)
330  `(stru ,src ,(- (arch::target-lisp-node-size (backend-target-arch *target-backend*))) ,stack))
331
332(defppclapmacro vpush (src)
333  `(push ,src vsp))
334
335;;; You typically don't want to do this to pop a single register (it's better to
336;;; do a sequence of loads, and then adjust the stack pointer.)
337
338(defppclapmacro pop (dest stack)
339  `(progn
340     (ldr ,dest 0 ,stack)
341     (la ,stack ,(arch::target-lisp-node-size (backend-target-arch *target-backend*)) ,stack)))
342
343(defppclapmacro vpop (dest)
344  `(pop ,dest vsp))
345
346(defppclapmacro %cdr (dest node)
347  (target-arch-case
348   (:ppc32 `(lwz ,dest ppc32::cons.cdr ,node))
349   (:ppc64 `(ld ,dest ppc64::cons.cdr ,node))))
350
351(defppclapmacro %car (dest node)
352  (target-arch-case
353   (:ppc32 `(lwz ,dest ppc32::cons.car ,node))
354   (:ppc64 `(ld ,dest ppc64::cons.car ,node))))
355
356(defppclapmacro extract-lisptag (dest node)
357  (let* ((tb *target-backend*))
358    `(clrlri ,dest ,node (- ,(arch::target-nbits-in-word (backend-target-arch tb))
359                          ,(arch::target-nlisptagbits (backend-target-arch tb))))))
360
361(defppclapmacro extract-fulltag (dest node)
362  (let* ((tb *target-backend*))
363  `(clrlri ,dest ,node (- ,(arch::target-nbits-in-word (backend-target-arch tb))
364                        ,(arch::target-ntagbits (backend-target-arch tb))))))
365
366(defppclapmacro extract-lowtag (dest node)
367  (target-arch-case
368   (:ppc32
369    (error "EXTRACT-LOWTAG lapmacro makes no sense on PPC32."))
370   (:ppc64
371    `(clrldi ,dest ,node (- 64 ppc64::nlowtagbits)))))
372
373
374(defppclapmacro extract-subtag (dest node)
375  (target-arch-case
376   (:ppc32
377    `(lbz ,dest ppc32::misc-subtag-offset ,node))
378   (:ppc64
379    `(lbz ,dest ppc64::misc-subtag-offset ,node))))
380
381(defppclapmacro extract-typecode (dest node &optional (crf :cr0))
382  (target-arch-case
383   (:ppc32
384    `(progn
385      (extract-lisptag ,dest ,node)
386      (cmpwi ,crf ,dest ppc32::tag-misc)
387      (if (,crf :eq)
388        (extract-subtag ,dest ,node))))
389   (:ppc64
390    `(progn
391      (extract-fulltag ,dest ,node)
392      (cmpdi ,crf ,dest ppc64::fulltag-misc)
393      (extract-lisptag ,dest ,dest)
394      (if (,crf :eq)
395        (extract-subtag ,dest ,node))))))
396
397(defppclapmacro trap-unless-lisptag= (node tag &optional (immreg ppc::imm0))
398  `(progn
399     (extract-lisptag ,immreg ,node)
400     (trnei ,immreg ,tag)))
401
402(defppclapmacro trap-unless-fulltag= (node tag &optional (immreg ppc::imm0))
403  `(progn
404     (extract-fulltag ,immreg ,node)
405     (trnei ,immreg ,tag)))
406
407
408(defppclapmacro trap-unless-typecode= (node tag &optional (immreg ppc::imm0) (crf :cr0))
409  `(progn
410     (extract-typecode ,immreg ,node ,crf)
411     (trnei ,immreg ,tag)))
412
413
414(defppclapmacro load-constant (dest constant)
415  `(ldr ,dest ',constant fn))
416
417;;; This is about as hard on the pipeline as anything I can think of.
418(defppclapmacro call-symbol (function-name)
419  (target-arch-case
420   (:ppc32
421    `(progn
422      (load-constant fname ,function-name)
423      (lwz nfn ppc32::symbol.fcell fname)
424      (lwz loc-pc ppc32::misc-data-offset nfn)
425      (mtctr loc-pc)
426      (bctrl)))
427   (:ppc64
428    `(progn
429      (load-constant fname ,function-name)
430      (ld nfn ppc64::symbol.fcell fname)
431      (ld loc-pc ppc64::misc-data-offset nfn)
432      (mtctr loc-pc)
433      (bctrl)))))
434
435(defppclapmacro sp-call-symbol (function-name)
436  `(progn
437     (load-constant fname ,function-name)
438     (bla .SPjmpsym)))
439
440(defppclapmacro getvheader (dest src)
441  (target-arch-case
442   (:ppc32
443    `(lwz ,dest ppc32::misc-header-offset ,src))
444   (:ppc64
445    `(ld ,dest ppc64::misc-header-offset ,src))))
446
447;;; "Size" is unboxed element-count.
448(defppclapmacro header-size (dest vheader)
449  (target-arch-case
450   (:ppc32
451    `(srwi ,dest ,vheader ppc32::num-subtag-bits))
452   (:ppc64
453    `(srdi ,dest ,vheader ppc64::num-subtag-bits))))
454
455
456;;; "Length" is fixnum element-count.
457(defppclapmacro header-length (dest vheader)
458  (target-arch-case
459   (:ppc32
460    `(rlwinm ,dest 
461      ,vheader 
462      (- ppc32::nbits-in-word (- ppc32::num-subtag-bits ppc32::nfixnumtagbits))
463      (- ppc32::num-subtag-bits ppc32::nfixnumtagbits)
464      (- ppc32::least-significant-bit ppc32::nfixnumtagbits)))
465   (:ppc64
466    `(progn
467      (rldicr ,dest
468       ,vheader
469       (- 64 (- ppc64::num-subtag-bits ppc64::fixnumshift))
470       (- 63 ppc64::fixnumshift))
471      (clrldi ,dest ,dest (- ppc64::num-subtag-bits ppc64::fixnumshift))))))
472 
473
474(defppclapmacro header-subtag[fixnum] (dest vheader)
475  (target-arch-case
476   (:ppc32
477    `(rlwinm ,dest
478           ,vheader
479           ppc32::fixnumshift
480           (- ppc32::nbits-in-word (+ ppc32::num-subtag-bits ppc32::nfixnumtagbits))
481           (- ppc32::least-significant-bit ppc32::nfixnumtagbits)))
482   (:ppc64
483    `(clrlsldi ,dest
484      ,vheader (- ppc64::nbits-in-word ppc64::num-subtag-bits)
485      ppc64::fixnumshift))))
486
487
488(defppclapmacro vector-size (dest v vheader)
489  `(progn
490     (getvheader ,vheader ,v)
491     (header-size ,dest ,vheader)))
492
493(defppclapmacro vector-length (dest v vheader)
494  `(progn
495     (getvheader ,vheader ,v)
496     (header-length ,dest ,vheader)))
497
498
499;;; Reference a 32-bit miscobj entry at a variable index.
500;;; Make the caller explicitly designate a scratch register
501;;; to use for the scaled index.
502
503(defppclapmacro vref32 (dest miscobj index scaled-idx)
504  `(progn
505     (la ,scaled-idx ppc32::misc-data-offset ,index)
506     (lwzx ,dest ,miscobj ,scaled-idx)))
507
508;; The simple (no-memoization) case.
509(defppclapmacro vset32 (src miscobj index scaled-idx)
510  `(progn
511     (la ,scaled-idx ppc32::misc-data-offset ,index)
512     (stwx ,src ,miscobj ,scaled-idx)))
513
514(defppclapmacro extract-lowbyte (dest src)
515  (target-arch-case
516   (:ppc32 `(clrlwi ,dest ,src (- 32 8)))
517   (:ppc64 `(clrldi ,dest ,src (- 64 8)))))
518
519(defppclapmacro unbox-fixnum (dest src)
520  (target-arch-case
521   (:ppc32
522    `(srawi ,dest ,src ppc32::fixnumshift))
523   (:ppc64
524    `(sradi ,dest ,src ppc64::fixnumshift))))
525
526(defppclapmacro box-fixnum (dest src)
527  (target-arch-case
528   (:ppc32
529    `(slwi ,dest ,src ppc32::fixnumshift))
530   (:ppc64
531    `(sldi ,dest ,src ppc64::fixnumshift))))
532
533
534
535;;; If crf is specified, type checks src
536(defppclapmacro unbox-base-char (dest src &optional crf)
537  (if (null crf)
538    (target-arch-case
539     (:ppc32 `(srwi ,dest ,src ppc32::charcode-shift))
540     (:ppc64 `(srdi ,dest ,src ppc64::charcode-shift)))
541    (let ((label (gensym)))
542      (target-arch-case
543       (:ppc32 `(progn
544                 (clrlwi ,dest ,src (- ppc32::nbits-in-word ppc32::charcode-shift))
545                 (cmpwi ,crf ,dest ppc32::subtag-character)
546                 (srwi ,dest ,src ppc32::charcode-shift)
547                 (beq+ ,crf ,label)
548                 (uuo_interr arch::error-object-not-base-char ,src)
549                 ,label))
550       (:ppc64
551        `(progn
552          (clrldi ,dest ,src (- ppc64::nbits-in-word ppc64::num-subtag-bits))
553          (cmpdi ,crf ,dest ppc64::subtag-character)
554          (srdi ,dest ,src ppc64::charcode-shift)
555          (beq+ ,crf ,label)
556          (uuo_interr arch::error-object-not-base-char ,src)
557          ,label))))))
558
559
560
561
562(defppclapmacro ref-global (reg sym)
563  (target-arch-case
564   (:ppc32
565    (let* ((offset (ppc32::%kernel-global sym)))
566      `(lwz ,reg (+ ,offset (target-nil-value)) 0)))
567   (:ppc64
568    (let* ((offset (ppc64::%kernel-global sym)))
569      `(ld ,reg (+ ,offset (target-nil-value)) 0)))))
570
571(defppclapmacro set-global (reg sym)
572  (target-arch-case
573   (:ppc32
574    (let* ((offset (ppc32::%kernel-global sym)))
575      `(stw ,reg (+ ,offset (target-nil-value)) 0)))
576   (:ppc64
577    (let* ((offset (ppc64::%kernel-global sym)))
578      `(std ,reg (+ ,offset (target-nil-value)) 0)))))
579
580;;; Set "dest" to those bits in "src" that are other than those that
581;;; would be set if "src" is a fixnum and of type (unsigned-byte
582;;; "width").  If no bits are set in "dest", then "src" is indeed of
583;;; type (unsigned-byte "width").  Set (:CR0 :EQ) according to the
584;;; result.
585(defppclapmacro extract-unsigned-byte-bits. (dest src width)
586  (target-arch-case
587   (:ppc32
588    `(rlwinm. ,dest ,src 0 (- 32 ppc32::fixnumshift) (- 31 (+ ,width ppc32::fixnumshift))))
589   (:ppc64
590    `(rldicr. ,dest ,src (- 64 ppc64::fixnumshift) (- 63 ,width)))))
591
592
593
594;;; You generally don't want to have to say "mfcr": it crosses functional
595;;; units and forces synchronization (all preceding insns must complete,
596;;; no subsequent insns may start.)
597;;; There are often algebraic ways of computing ppc32::t-offset:
598
599;;; Src has all but the least significant bit clear.  Map low bit to T/NIL.
600(defppclapmacro bit0->boolean (dest src temp)
601  (target-arch-case
602   (:ppc32
603    `(progn
604      (rlwimi ,temp ,src 4 27 27)
605      (addi ,dest ,temp (target-nil-value))))
606   (:ppc64
607    `(progn
608      (mulli ,temp ,src ppc64::t-offset) ; temp = ppc64::t-offset, or 0
609      (addi ,dest ,temp (target-nil-value)))))) ; dest = (src == 1), lisp-wise
610
611(defppclapmacro eq0->boolean (dest src temp)
612  (target-arch-case
613   (:ppc32
614    `(progn
615      (cntlzw ,temp ,src)                ; 32 leading zeros if (src == 0)
616      (srwi ,temp ,temp 5)               ; temp = (src == 0), C-wise
617      (bit0->boolean ,dest ,temp ,temp)))
618   (:ppc64
619    `(progn
620      (cntlzd ,temp ,src)               ; 64 leading zeros if (src == 0)
621      (srdi ,temp ,temp 6)              ; temp = (src == 0), C-wise
622      (bit0->boolean ,dest ,temp ,temp)))))
623
624(defppclapmacro ne0->boolean (dest src temp)
625  (target-arch-case
626   (:ppc32
627    `(progn
628      (cntlzw ,temp ,src)               
629      (slw ,temp ,src ,temp)
630      (srwi ,temp ,temp 31)
631      (bit0->boolean ,dest ,temp ,temp)))
632   (:ppc64
633    `(progn
634      (cntlzd ,temp ,src)
635      (sld ,temp ,src ,temp)
636      (srdi ,temp ,temp 63) 
637      (bit0->boolean ,dest ,temp ,temp)))))
638
639(defppclapmacro eq->boolean (dest rx ry temp)
640  `(progn
641     (sub ,temp ,rx ,ry)
642     (eq0->boolean ,dest ,temp ,temp)))
643
644
645(defppclapmacro repeat (n inst)
646  (let* ((insts ()))
647    (dotimes (i n `(progn ,@(nreverse insts)))
648      (push inst insts))))
649
650(defppclapmacro get-single-float (dest node)
651  (target-arch-case
652   (:ppc32
653    `(lfs ,dest ppc32::single-float.value ,node))
654   (:ppc64
655    `(progn
656      (std ,node ppc64::tcr.single-float-convert ppc64::rcontext)
657      (lfs ,dest ppc64::tcr.single-float-convert ppc64::rcontext)))))
658
659(defppclapmacro get-double-float (dest node)
660  (target-arch-case
661   (:ppc32
662    `(lfd ,dest ppc32::double-float.value ,node))
663   (:ppc64
664    `(lfd ,dest ppc64::double-float.value ,node))))
665 
666
667(defppclapmacro put-single-float (src node)
668  (target-arch-case
669   (:ppc32
670    `(stfs ,src ppc32::single-float.value ,node))
671   (:ppc64
672    `(progn
673      (stfs ,src ppc64::tcr.single-float-convert ppc64::rcontext)
674      (ld ,node ppc64::tcr.single-float-convert ppc64::rcontext)))))
675
676(defppclapmacro put-double-float (src node)
677  (target-arch-case
678   (:ppc32
679    `(stfd ,src ppc32::double-float.value ,node))
680   (:ppc64
681    `(stfd ,src ppc64::double-float.value ,node))))
682
683(defppclapmacro clear-fpu-exceptions ()
684  `(mtfsf #xfc #.ppc::fp-zero))
685
686
687
688;;; from ppc-bignum.lisp
689(defppclapmacro digit-h (dest src)
690  (target-arch-case
691   (:ppc32
692    `(rlwinm ,dest ,src (+ 16 ppc32::fixnumshift) (- 16 ppc32::fixnumshift) (- 31 ppc32::fixnumshift)))
693   (:ppc64
694    (error "DIGIT-H on PPC64 ?"))))
695
696;;; from ppc-bignum.lisp
697(defppclapmacro digit-l (dest src)
698  (target-arch-case
699   (:ppc32
700    `(clrlslwi ,dest ,src 16 ppc32::fixnumshift))
701   (:ppc64
702    (error "DIGIT-L on PPC64 ?"))))
703 
704;;; from ppc-bignum.lisp
705(defppclapmacro compose-digit (dest high low)
706  (target-arch-case
707   (:ppc32
708    `(progn
709      (rlwinm ,dest ,low (- ppc32::nbits-in-word ppc32::fixnumshift) 16 31)
710      (rlwimi ,dest ,high (- 16 ppc32::fixnumshift) 0 15)))
711   (:ppc64
712    (error "COMPOSE-DIGIT on PPC64 ?"))))
713
714(defppclapmacro macptr-ptr (dest macptr)
715  (target-arch-case
716   (:ppc32
717    `(lwz ,dest ppc32::macptr.address ,macptr))
718   (:ppc64
719    `(ld ,dest ppc64::macptr.address ,macptr))))
720
721(defppclapmacro svref (dest index vector)
722  (target-arch-case
723   (:ppc32
724    `(lwz ,dest (+ (* 4 ,index) ppc32::misc-data-offset) ,vector))
725   (:ppc64
726    `(ld ,dest (+ (* 8 ,index) ppc64::misc-data-offset) ,vector))))
727
728;;; This evals its args in the wrong order.
729;;; Can't imagine any code will care.
730(defppclapmacro svset (new-value index vector)
731  (target-arch-case
732   (:ppc32
733    `(stw ,new-value (+ (* 4 ,index) ppc32::misc-data-offset) ,vector))
734   (:ppc64
735    `(std ,new-value (+ (* 8 ,index) ppc64::misc-data-offset) ,vector))))
736
737(defppclapmacro vpush-argregs ()
738  (let* ((none (gensym))
739         (two (gensym))
740         (one (gensym)))
741  `(progn
742     (cmpri cr1 nargs '2)
743     (cmpri cr0 nargs 0)
744     (beq cr1 ,two)
745     (beq cr0 ,none)
746     (blt cr1 ,one)
747     (vpush arg_x)
748     ,two
749     (vpush arg_y)
750     ,one
751     (vpush arg_z)
752     ,none)))
753
754
755
756;;; Saving and restoring AltiVec registers.
757
758;;; Note that under the EABI (to which PPCLinux conforms), the OS
759;;; doesn't attach any special significance to the value of the VRSAVE
760;;; register (spr 256).  Under some other ABIs, VRSAVE is a bitmask
761;;; which indicates which vector registers are live at context switch
762;;; time.  These macros contain code to maintain VRSAVE when the
763;;; variable *ALTIVEC-LAPMACROS-MAINTAIN-VRSAVE-P* is true at
764;;; macroexpand time; that variable is initialized to true if and only
765;;; if :EABI-TARGET is not on *FEATURES*.  Making this behavior
766;;; optional is supposed to help make code which uses these macros
767;;; easier to port to other platforms.
768
769;;; From what I can tell, a function that takes incoming arguments in
770;;; vector registers (vr2 ... vr13) (and doesn't use any other vector
771;;; registers) doesn't need to assert that it uses any vector
772;;; registers (even on platforms that maintain VRSAVE.)  A function
773;;; that uses vector registers that were not incoming arguments has to
774;;; assert that it uses those registers on platforms that maintain
775;;; VRSAVE.  On all platforms, a function that uses any non-volatile
776;;; vector registers (vr20 ... vr31) has to assert that it uses these
777;;; registers and save and restore the caller's value of these registers
778;;; around that usage.
779
780(defparameter *altivec-lapmacros-maintain-vrsave-p*
781  #-eabi-target t
782  #+eabi-target nil
783  "Control the expansion of certain lap macros. Initialized to NIL on
784LinuxPPC; initialized to T on platforms (such as MacOS X/Darwin) that
785require that the VRSAVE SPR contain a bitmask of active vector registers
786at all times.")
787
788(defun %vr-register-mask (reglist)
789  (let* ((mask 0))
790    (dolist (reg reglist mask)
791      (let* ((regval (ppc-vector-register-name-or-expression reg)))
792        (unless (typep regval '(mod 32))
793          (error "Bad AltiVec register - ~s" reg))
794        (setq mask (logior mask (ash #x80000000 (- regval))))))))
795
796
797
798;;; Build a frame on the temp stack large enough to hold N 128-bit vector
799;;; registers and the saved value of the VRSAVE spr.  That frame will look
800;;; like:
801;;; #x??????I0   backpointer to previous tstack frame
802;;; #x??????I4   non-zero marker: frame doesn't contain tagged lisp data
803;;; #x??????I8   saved VRSAVE
804;;; #x??????IC   pad word for alignment
805;;; #x??????J0   first saved vector register
806;;; #x??????K0   second saved vector register
807;;;   ...
808;;; #x??????X0   last saved vector register
809;;; #x??????Y0   (possibly) 8 bytes wasted for alignment.
810;;; #x????????   UNKNOWN; not necessarily the previous tstack frame
811;;;
812;;;  Use the specified immediate register to build the frame.
813;;;  Save the caller's VRSAVE in the frame.
814
815(defppclapmacro %build-vrsave-frame (n tempreg)
816  (if (or (> n 0) *altivec-lapmacros-maintain-vrsave-p*)
817    (if (zerop n)
818      ;; Just make room for vrsave; no need to align to 16-byte boundary.
819      `(progn
820        (stwu tsp -16 tsp)
821        (stw tsp 4 tsp))
822      `(progn
823        (la ,tempreg ,(- (ash (1+ n) 4)) ppc::tsp)
824        (clrrwi ,tempreg ,tempreg 4)    ; align to 16-byte boundary
825        (sub ,tempreg ,tempreg ppc32::tsp) ; calculate (aligned) frame size.
826        (stwux ppc::tsp ppc::tsp ,tempreg)
827        (stw ppc::tsp 4 ppc::tsp)))     ; non-zero: non-lisp
828    `(progn)))
829
830;;; Save the current value of the VRSAVE spr in the newly-created
831;;; tstack frame.
832
833(defppclapmacro %save-vrsave (tempreg)
834  (if *altivec-lapmacros-maintain-vrsave-p*
835    `(progn
836      (mfspr ,tempreg 256)              ; SPR 256 = vrsave
837      (stw ,tempreg 8 tsp))
838    `(progn)))
839
840
841
842;;; When this is expanded, "tempreg" should contain the caller's vrsave.
843(defppclapmacro %update-vrsave (tempreg mask)
844  (let* ((mask-high (ldb (byte 16 16) mask))
845         (mask-low (ldb (byte 16 0) mask)))
846    `(progn
847       ,@(unless (zerop mask-high) `((oris ,tempreg ,tempreg ,mask-high)))
848       ,@(unless (zerop mask-low) `((ori ,tempreg ,tempreg ,mask-low)))
849       (mtspr 256 ,tempreg))))
850
851;;; Save each of the vector regs in "nvrs" into the current tstack
852;;; frame, starting at offset 16
853(defppclapmacro %save-vector-regs (nvrs tempreg)
854  (let* ((insts ()))
855    (do* ((offset 16 (+ 16 offset))
856          (regs nvrs (cdr regs)))
857         ((null regs) `(progn ,@(nreverse insts)))
858      (declare (fixnum offset))
859      (push `(la ,tempreg ,offset ppc::tsp) insts)
860      (push `(stvx ,(car regs) ppc::rzero ,tempreg) insts))))
861
862
863;;; Pretty much the same idea, only we restore VRSAVE first and
864;;; discard the tstack frame after we've reloaded the vector regs.
865(defppclapmacro %restore-vector-regs (nvrs tempreg)
866  (let* ((loads ()))
867    (do* ((offset 16 (+ 16 offset))
868          (regs nvrs (cdr regs)))
869         ((null regs) `(progn
870                        ,@ (when *altivec-lapmacros-maintain-vrsave-p*
871                             `((progn
872                                 (lwz ,tempreg 8 ppc::tsp)
873                                 (mtspr 256 ,tempreg))))
874                        ,@(nreverse loads)
875                        (lwz ppc::tsp 0 ppc::tsp)))
876      (declare (fixnum offset))
877      (push `(la ,tempreg ,offset ppc::tsp) loads)
878      (push `(lvx ,(car regs) ppc::rzero ,tempreg) loads))))
879
880
881(defun %extract-non-volatile-vector-registers (vector-reg-list)
882  (let* ((nvrs ()))
883    (dolist (reg vector-reg-list (nreverse nvrs))
884      (let* ((regval (ppc-vector-register-name-or-expression reg)))
885        (unless (typep regval '(mod 32))
886          (error "Bad AltiVec register - ~s" reg))
887        (when (>= regval 20)
888          (pushnew regval nvrs))))))
889
890
891;;; One could imagine something more elaborate:
892;;; 1) Binding a global bitmask that represents the assembly-time notion
893;;;    of VRSAVE's contents; #'ppc-vector-register-name-or-expression
894;;;    could then warn if a vector register wasn't marked as active.
895;;;    Maybe a good idea, but PPC-LAP would have to bind that special
896;;;    variable to 0 to make things reentrant.
897;;; 2) Binding a user-specified variable to the list of NVRs that need
898;;;    to be restored, so that it'd be more convenient to insert one's
899;;;    own calls to %RESTORE-VECTOR-REGS at appropriate points.
900;;; Ad infinitum.  As is, this allows one to execute a "flat" body of code
901;;;   that's bracketed by the stuff needed to keep VRSAVE in sync and
902;;;   to save and restore any non-volatile vector registers specified.
903;;;   That body of code is "flat" in the sense that it doesn't return,
904;;;   tail-call, establish a catch or unwind-protect frame, etc.
905;;;   It -can- contain lisp or foreign function calls.
906
907(defppclapmacro %with-altivec-registers ((&key (immreg 'ppc::imm0)) reglist &body body)
908  (let* ((mask (%vr-register-mask reglist))
909         (nvrs (%extract-non-volatile-vector-registers reglist))
910         (num-nvrs (length nvrs)))
911    (if (or *altivec-lapmacros-maintain-vrsave-p* nvrs)
912      `(progn
913        (%build-vrsave-frame ,num-nvrs ,immreg)
914        (%save-vrsave ,immreg)
915        ,@ (if *altivec-lapmacros-maintain-vrsave-p*
916             `((%update-vrsave ,immreg ,mask)))
917        (%save-vector-regs ,nvrs ,immreg)
918        (progn ,@body)
919        (%restore-vector-regs ,nvrs ,immreg))
920      `(progn ,@body))))
921
922
923(defppclapmacro with-altivec-registers (reglist &body body)
924  "Specify the set of AltiVec registers used in body. If
925*altivec-lapmacros-maintain-vrsave-p* is true when the macro is expanded,
926generates code to save the VRSAVE SPR and updates VRSAVE to incude a
927bitmask generated from the specified register list. Generates code which
928saves any non-volatile vector registers which appear in the register list,
929executes body, and restores the saved non-volatile vector registers (and,
930if *altivec-lapmacros-maintain-vrsave-p* is true, restores VRSAVE as well.
931Uses the IMM0 register (r3) as a temporary."
932  `(%with-altivec-registers () ,reglist ,@body))
933
934
935;;; Create an aligned buffer on the temp stack, large enough for N vector
936;;; registers.  Make base be a pointer to this buffer (base can be
937;;; any available GPR, since the buffer will be fixnum-tagged.) N should
938;;; be a constant.
939;;; The intent here is that the register 'base' can be used in subsequent
940;;; stvx/lvx instructions.  Any vector registers involved in such instructions
941;;; must have their corresponding bits saved in VRSAVE on platforms where
942;;; that matters.
943
944(defppclapmacro allocate-vector-buffer (base n)
945  `(progn
946    (stwux tsp (- (ash (1+ ,n) 4)))     ; allocate a frame on temp stack
947    (stw tsp 4 tsp)                     ; temp frame contains immediate data
948    (la ,base (+ 8 8) tsp)              ; skip header, round up
949    (clrrwi ,base ,base 4)))            ; align (round down)
950
951;;; Execute the specified body of code; on entry to that body, BASE
952;;; will point to the lowest address of a vector-aligned buffer with
953;;; room for N vector registers.  On exit, the buffer will be
954;;; deallocated.  The body should preserve the value of BASE as long
955;;; as it needs to reference the buffer.
956
957(defppclapmacro with-vector-buffer (base n &body body)
958  "Generate code which allocates a 16-byte aligned buffer large enough
959to contain N vector registers; the GPR base points to the lowest address
960of this buffer. After processing body, the buffer will be deallocated.
961The body should preserve the value of base as long as it needs to
962reference the buffer. It's intended that base be used as a base register
963in stvx and lvx instructions within the body."
964  `(progn
965    (allocate-vector-buffer ,base ,n)
966    (progn
967      (progn ,@body)
968      (unlink tsp))))
969
970#|
971
972;;; This is just intended to test the macros; I can't test whether or not the code works.
973
974(defppclapfunction load-array ((n arg_z))
975  (check-nargs 1)
976  (with-altivec-registers (vr1 vr2 vr3 vr27) ; Clobbers imm0
977    (li imm0 ppc32::misc-data-offset)
978    (lvx vr1 arg_z imm0)                ; load MSQ
979    (lvsl vr27 arg_z imm0)              ; set the permute vector
980    (addi imm0 imm0 16)                 ; address of LSQ
981    (lvx vr2 arg_z imm0)                ; load LSQ
982    (vperm vr3 vr1 vr2 vr27)            ; aligned result appears in VR3
983    (dbg t))                            ; Look at result in some debugger
984  (blr))
985|#
986
987;;; see "Optimizing PowerPC Code" p. 156
988;;; Note that the constant #x4330000080000000 is now in fp-s32conv
989
990(defppclapmacro int-to-freg (int freg imm)
991  (target-arch-case
992   (:ppc32
993    `(let ((temp 8)
994           (temp.h 8)
995           (temp.l 12))
996      (stwu tsp -16 tsp)
997      (stw tsp 4 tsp)
998      (stfd ppc::fp-s32conv temp tsp)
999      (unbox-fixnum ,imm ,int)
1000      (xoris ,imm ,imm #x8000)       ; invert sign of unboxed fixnum
1001      (stw ,imm temp.l tsp)
1002      (lfd ,freg temp tsp)
1003      (lwz tsp 0 tsp)
1004      (fsub ,freg ,freg ppc::fp-s32conv)))
1005   (:ppc64
1006    `(progn
1007      (unbox-fixnum ,imm ,int)
1008      (std ,imm -8 sp)
1009      (lfd ,freg -8 sp)
1010      (fcfid ,freg ,freg)))))
1011
1012;;; Set the most significant bit in DEST, clear all other bits.
1013(defppclapmacro load-highbit (dest)
1014  (target-arch-case
1015   (:ppc32
1016    `(lis ,dest #x8000))
1017   (:ppc64
1018    `(progn
1019      (lis ,dest #x8000)
1020      (sldi ,dest ,dest 32)))))
1021
1022(defppclapmacro extract-bit-shift-count (dest src)
1023  (target-arch-case
1024   (:ppc32 `(clrlwi ,dest ,src (- 32 ppc32::bitmap-shift)))
1025   (:ppc64 `(clrldi ,dest ,src (- 64 ppc64::bitmap-shift)))))
1026
1027;;; "index" is the result of subtracting a base address from some
1028;;; possibly tagged pointer.  "bitwords" is the address of the first
1029;;; word of an (untagged) bitvector.
1030(defppclapmacro set-bit-at-index (bitwords index &optional (mask ppc::imm3) (count ppc::imm4) (was ppc::imm1))
1031  (let* ((done (gensym))
1032         (again (gensym)))
1033    `(progn
1034      (load-highbit ,mask)
1035      (srri ,index ,index ,(target-arch-case
1036                            (:ppc32 ppc32::dnode-shift)
1037                            (:ppc64 ppc64::dnode-shift)))
1038      (extract-bit-shift-count ,count ,index)
1039      (srr ,mask ,mask ,count)
1040      (srri ,index ,index ,(target-arch-case
1041                            (:ppc32 ppc32::bitmap-shift)
1042                            (:ppc64 ppc64::bitmap-shift)))
1043      (slri ,index ,index  ,(target-arch-case
1044                            (:ppc32 ppc32::word-shift)
1045                            (:ppc64 ppc64::word-shift)))
1046      (ldrx ,was ,bitwords ,index)
1047      (and. ,was ,was ,mask)
1048      (bne ,done)
1049      ,again
1050      (lrarx ,was ,bitwords ,index)
1051      (or ,was ,was ,mask)
1052      (strcx. ,was ,bitwords ,index)
1053      (bne ,again)
1054      ,done)))
1055
1056;;; Like SET-BIT-AT-INDEX, but sets CR0[EQ] iff the index'th bit
1057;;; is set.
1058(defppclapmacro test-bit-at-index (bitwords index &optional (mask ppc::imm3) (count ppc::imm4) (was ppc::imm1))
1059  `(progn
1060    (load-highbit ,mask)
1061    (srri ,index ,index ,(target-arch-case
1062                          (:ppc32 ppc32::dnode-shift)
1063                          (:ppc64 ppc64::dnode-shift)))
1064    (extract-bit-shift-count ,count ,index)
1065    (srr ,mask ,mask ,count)
1066    (srri ,index ,index ,(target-arch-case
1067                          (:ppc32 ppc32::bitmap-shift)
1068                          (:ppc64 ppc64::bitmap-shift)))
1069    (slri ,index ,index  ,(target-arch-case
1070                           (:ppc32 ppc32::word-shift)
1071                           (:ppc64 ppc64::word-shift)))
1072    (ldrx ,was ,bitwords ,index)
1073    (and. ,mask ,was ,mask)))
1074                                           
1075
1076(provide "PPC-LAPMACROS")
1077
1078;;; end of ppc-lapmacros.lisp
Note: See TracBrowser for help on using the repository browser.