source: trunk/source/level-0/PPC/ppc-def.lisp @ 11587

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

Stop pretending to support :MONITOR-EXCEPTION-PORTS in the runtime %FF-CALL.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 42.5 KB
Line 
1;;; -*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19;;; Do an FF-CALL to MakeDataExecutable so that the data cache gets flushed.
20;;; If the GC moves this function while we're trying to flush the cache,
21;;; it'll flush the cache: no harm done in that case.
22(defppclapfunction %make-code-executable ((codev arg_z))
23  (let ((len imm2)
24        (word-offset imm0))
25    (save-lisp-context)
26    (getvheader word-offset codev)
27    (header-size len word-offset)
28    ;; The idea is that if we GC here, no harm is done (since the GC
29    ;; will do any necessary cache-flushing.)  The idea may be
30    ;; incorrect: if we pass an address that's not mapped anymore,
31    ;; could we fault ?
32    (stru sp (- (+ #+eabi-target ppc32::eabi-c-frame.minsize
33                   #+poweropen-target target::c-frame.minsize target::lisp-frame.size)) sp)     ; make an FFI frame.
34    (la imm0 target::misc-data-offset codev)
35    (slri len len 2)
36    (str imm0 #+eabi-target ppc32::eabi-c-frame.param0 #+poweropen-target target::c-frame.param0  sp)
37    (str len #+eabi-target ppc32::eabi-c-frame.param1 #+poweropen-target target::c-frame.param1 sp)
38    (ref-global imm3 kernel-imports)
39    (ldr arg_z target::kernel-import-MakeDataExecutable imm3)
40    (bla #+eabi-target .SPeabi-ff-call #+poweropen-target .SPpoweropen-ffcall)
41    (li arg_z nil)
42    (restore-full-lisp-context)
43    (blr)))
44
45(defppclapfunction %get-kernel-global-from-offset ((offset arg_z))
46  (check-nargs 1)
47  (unbox-fixnum imm0 offset)
48  (addi imm0 imm0 (target-nil-value))
49  (ldr arg_z 0 imm0)
50  (blr))
51
52(defppclapfunction %set-kernel-global-from-offset ((offset arg_y) (new-value arg_z))
53  (check-nargs 2)
54  (unbox-fixnum imm0 offset)
55  (addi imm0 imm0 (target-nil-value))
56  (str new-value 0 imm0)
57  (blr))
58
59
60
61(defppclapfunction %get-kernel-global-ptr-from-offset ((offset arg_y)
62                                                       (ptr arg_z))
63  (check-nargs 2)
64  (unbox-fixnum imm0 offset)
65  (addi imm0 imm0 (target-nil-value))
66  (ldr imm0 0 imm0)
67  (str imm0 target::macptr.address ptr)
68  (blr))
69
70
71
72
73(defppclapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z))
74  (cmpri cr0 nargs '1)
75  (check-nargs 1 2)
76  (bne cr0 @2-args)
77  (mr fixnum offset)
78  (li offset 0)
79  @2-args
80  (unbox-fixnum imm0 offset)
81  (ldrx arg_z imm0 fixnum)
82  (blr))
83
84
85#+ppc32-target
86(defppclapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z))
87  (cmpri cr0 nargs '1)
88  (check-nargs 1 2)
89  (bne cr0 @2-args)
90  (mr fixnum offset)
91  (li offset 0)
92  @2-args
93  (unbox-fixnum imm0 offset)
94  (lwzx imm0 imm0 fixnum)
95  (ba .SPmakeu32))
96
97#+ppc64-target
98(defppclapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z))
99  (cmpdi cr0 nargs '1)
100  (check-nargs 1 2)
101  (bne cr0 @2-args)
102  (mr fixnum offset)
103  (li offset 0)
104  @2-args
105  (unbox-fixnum imm0 offset)
106  (ldx imm0 imm0 fixnum)
107  (ba .SPmakeu64))
108
109(defppclapfunction %fixnum-set ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z))
110  (cmpi cr0 nargs '2)
111  (check-nargs 2 3)
112  (bne cr0 @3-args)
113  (mr fixnum offset)
114  (li offset 0)
115  @3-args
116  (unbox-fixnum imm0 offset)
117  (strx new-value imm0 fixnum)
118  (mr arg_z new-value)
119  (blr))
120
121#+ppc32-target
122(defppclapfunction %fixnum-set-natural ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z))
123  (cmpwi cr0 nargs '2)
124  (check-nargs 2 3)
125  (bne cr0 @3-args)
126  (mr fixnum offset)
127  (li offset 0)
128  @3-args
129  (unbox-fixnum imm0 offset)
130  (extract-typecode imm1 new-value)
131  (cmpwi cr0 imm1 ppc32::tag-fixnum)
132  (cmpwi cr1 imm1 ppc32::subtag-bignum)
133  (srwi imm2 new-value ppc32::fixnumshift)
134  (beq cr0 @store)
135  (beq cr1 @bignum)
136  @notu32
137  (uuo_interr arch::error-object-not-unsigned-byte-32 new-value)
138  @bignum
139  (getvheader imm0 new-value)
140  (cmpwi cr1 imm0 ppc32::one-digit-bignum-header)
141  (cmpwi cr2 imm0 ppc32::two-digit-bignum-header)
142  (lwz imm2 ppc32::misc-data-offset new-value)
143  (cmpwi cr0 imm2 0)
144  (beq cr1 @one)
145  (bne cr2 @notu32)
146  (lwz imm1 (+ 4 ppc32::misc-data-offset) new-value)
147  (cmpwi cr1 imm1 0)
148  (bgt cr0 @notu32)
149  (beq cr1 @store)
150  (b @notu32)
151  @one
152  (blt cr0 @notu32)
153  @store
154  (stwx imm2 imm0 fixnum)
155  (mr arg_z new-value)
156  (blr))
157
158#+ppc64-target
159(defppclapfunction %fixnum-set-natural ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z))
160  (cmpdi cr0 nargs '2)
161  (check-nargs 2 3)
162  (bne cr0 @3-args)
163  (mr fixnum offset)
164  (li offset 0)
165  @3-args
166  (unbox-fixnum imm0 offset)
167  (extract-typecode imm1 new-value)
168  (cmpdi cr0 imm1 ppc64::tag-fixnum)
169  (cmpdi cr1 imm1 ppc64::subtag-bignum)
170  (srdi imm2 new-value ppc64::fixnumshift)
171  (beq cr0 @store)
172  (beq cr1 @bignum)
173  @notu64
174  (uuo_interr arch::error-object-not-unsigned-byte-64 new-value)
175  @bignum
176  (ld imm2 ppc64::misc-data-offset new-value)
177  (getvheader imm0 new-value)
178  (cmpdi cr1 imm0 ppc64::two-digit-bignum-header)
179  (rotldi imm2 imm2 32)
180  (cmpdi cr2 imm0 ppc64::three-digit-bignum-header)
181  (cmpdi cr0 imm2 0)
182  (beq cr1 @two)
183  (bne cr2 @notu64)
184  (lwz imm1 (+ 8 ppc64::misc-data-offset) new-value)
185  (cmpwi cr1 imm1 0)
186  (bgt cr0 @notu64)
187  (beq cr1 @store)
188  (b @notu64)
189  @two
190  (blt cr0 @notu64)
191  @store
192  (stdx imm2 imm0 fixnum)
193  (mr arg_z new-value)
194  (blr))
195
196
197(defppclapfunction %current-frame-ptr ()
198  (check-nargs 0)
199  (mr arg_z sp)
200  (blr))
201
202(defppclapfunction %current-vsp ()
203  (check-nargs 0)
204  (mr arg_z vsp)
205  (blr))
206
207
208
209
210(defppclapfunction %set-current-vsp ((new-vsp arg_z))
211  (check-nargs 1)
212  (mr vsp new-vsp)
213  (blr))
214
215(defppclapfunction %current-tsp ()
216  (check-nargs 0)
217  (mr arg_z tsp)
218  (blr))
219
220
221
222(defppclapfunction %set-current-tsp ((new-tsp arg_z))
223  (check-nargs 1)
224  (mr tsp new-tsp)
225  (blr))
226
227(defppclapfunction %%frame-backlink ((p arg_z))
228  (check-nargs 1)
229  (ldr arg_z target::lisp-frame.backlink arg_z)
230  (blr))
231
232
233
234
235
236(defppclapfunction %%frame-savefn ((p arg_z))
237  (check-nargs 1)
238  (ldr arg_z target::lisp-frame.savefn arg_z)
239  (blr))
240
241(defppclapfunction %cfp-lfun ((p arg_z))
242  (ldr arg_y target::lisp-frame.savefn p)
243  (extract-typecode imm0 arg_y)
244  (cmpri imm0 target::subtag-function)
245  (ldr loc-pc target::lisp-frame.savelr p)
246  (bne @no)
247  (ldr arg_x target::misc-data-offset arg_y)
248  (sub imm1 loc-pc arg_x)
249  (la imm1 (- target::misc-data-offset) imm1)
250  (getvheader imm0 arg_x)
251  (header-length imm0 imm0)
252  (cmplr imm1 imm0)
253  (box-fixnum imm1 imm1)
254  (bge @no)
255  (vpush arg_y)
256  (vpush imm1)
257  @go
258  (set-nargs 2)
259  (la temp0 '2 vsp)
260  (ba .SPvalues)
261  @no
262  (li imm0 nil)
263  (vpush imm0)
264  (vpush imm0)
265  (b @go))
266
267
268
269
270(defppclapfunction %%frame-savevsp ((p arg_z))
271  (check-nargs 1)
272  (ldr arg_z target::lisp-frame.savevsp arg_z)
273  (blr))
274
275
276
277
278
279#+ppc32-target
280(eval-when (:compile-toplevel :execute)
281  (assert (eql ppc32::t-offset #x11)))
282
283(defppclapfunction %uvector-data-fixnum ((uv arg_z))
284  (check-nargs 1)
285  (trap-unless-fulltag= arg_z target::fulltag-misc)
286  (la arg_z target::misc-data-offset arg_z)
287  (blr))
288
289(defppclapfunction %catch-top ((tcr arg_z))
290  (check-nargs 1)
291  (ldr arg_z target::tcr.catch-top tcr)
292  (cmpri cr0 arg_z 0)
293  (bne @ret)
294  (li arg_z nil)
295 @ret
296  (blr))
297
298(defppclapfunction %catch-tsp ((catch arg_z))
299  (check-nargs 1)
300  (la arg_z (- (+ target::fulltag-misc
301                                 (ash 1 (1+ target::word-shift)))) arg_z)
302  (blr))
303
304
305
306;;; Same as %address-of, but doesn't cons any bignums
307;;; It also left shift fixnums just like everything else.
308(defppclapfunction %fixnum-address-of ((x arg_z))
309  (check-nargs 1)
310  (box-fixnum arg_z x)
311  (blr))
312
313
314
315(defppclapfunction %save-standard-binding-list ((bindings arg_z))
316  (ldr imm0 target::tcr.vs-area target::rcontext)
317  (ldr imm1 target::area.high imm0)
318  (push bindings imm1)
319  (blr))
320
321(defppclapfunction %saved-bindings-address ()
322  (ldr imm0 target::tcr.vs-area target::rcontext)
323  (ldr imm1 target::area.high imm0)
324  (la arg_z (- target::node-size) imm1)
325  (blr))
326
327(defppclapfunction %code-vector-pc ((code-vector arg_y) (pcptr arg_z))
328  (macptr-ptr imm0 pcptr)
329  (ldr loc-pc 0 imm0)
330  (sub imm0 loc-pc code-vector)
331  (subi imm0 imm0 target::misc-data-offset)
332  (getvheader imm1 code-vector)
333  (header-size imm1 imm1)
334  (slri imm1 imm1 2)
335  (cmplr imm0 imm1)
336  (li arg_z nil)
337  (bgelr)
338  (box-fixnum arg_z imm0)
339  (blr))
340
341;;; FF-call, in LAP.
342#+eabi-target
343(progn
344  (defppclapfunction %%ff-call ((fploads 8)
345                                (single-offset 4)
346                                (double-offset 0)
347                                (framesize arg_x) ;always even, negative, includes frame overhead
348                                (buf arg_y)
349                                (entry arg_z))
350    (check-nargs 6)
351    (la imm0 12 vsp)
352    (save-lisp-context imm0)
353    (stwux sp sp framesize)
354    (stw sp 4 sp)
355    (macptr-ptr imm2 buf)
356    (mr imm1 imm2)
357    (la imm3 ppc32::eabi-c-frame.param0 sp)
358    (li imm0 0)
359    (lwz temp1 single-offset vsp)
360    (lwz temp2 double-offset vsp)
361    @copy
362    (addi imm0 imm0 8)
363    (cmpw imm0 temp1)
364    (lfd fp0 0 imm2)
365    (la imm2 8 imm2)
366    (stfd fp0 0 imm3)
367    (la imm3 8 imm3)
368    (blt @copy)
369    ;; We've copied the gpr-save area and the "other" arg words.
370    ;; Sadly, we may still need to load up to 8 FPRs, and we have
371    ;; to use some pretty ugly code to do so.
372    (add temp1 temp1 imm1)
373    (add temp2 temp2 imm1)
374    (lwz temp0 fploads vsp)
375    @load-fp1
376    (lbz imm0 (+ ppc32::misc-data-offset 0) temp0)
377    (cmpwi imm0 1)
378    (blt @loaded)
379    (bne @load-fp1-double)
380    (lfs fp1 0 temp1)
381    (la temp1 4 temp1)
382    (b @load-fp2)
383    @load-fp1-double
384    (lfd fp1 0 temp2)
385    (la temp2 8 temp2)
386    @load-fp2
387    (lbz imm0 (+ ppc32::misc-data-offset 1) temp0)
388    (cmpwi imm0 1)
389    (blt @loaded)
390    (bne @load-fp2-double)
391    (lfs fp2 0 temp1)
392    (la temp1 4 temp1)
393    (b @load-fp3)
394    @load-fp2-double
395    (lfd fp2 0 temp2)
396    (la temp2 8 temp2)
397    @load-fp3
398    (lbz imm0 (+ ppc32::misc-data-offset 2) temp0)
399    (cmpwi imm0 1)
400    (blt @loaded)
401    (bne @load-fp3-double)
402    (lfs fp3 0 temp1)
403    (la temp1 4 temp1)
404    (b @load-fp4)
405    @load-fp3-double
406    (lfd fp3 0 temp2)
407    (la temp2 8 temp2)
408    @load-fp4
409    (lbz imm0 (+ ppc32::misc-data-offset 3) temp0)
410    (cmpwi imm0 1)
411    (blt @loaded)
412    (bne @load-fp4-double)
413    (lfs fp4 0 temp1)
414    (la temp1 4 temp1)
415    (b @load-fp5)
416    @load-fp4-double
417    (lfd fp4 0 temp2)
418    (la temp2 8 temp2)
419    @load-fp5
420    (lbz imm0 (+ ppc32::misc-data-offset 4) temp0)
421    (cmpwi imm0 1)
422    (blt @loaded)
423    (bne @load-fp5-double)
424    (lfs fp5 0 temp1)
425    (la temp1 4 temp1)
426    (b @load-fp6)
427    @load-fp5-double
428    (lfd fp5 0 temp2)
429    (la temp2 8 temp2)
430    @load-fp6
431    (lbz imm0 (+ ppc32::misc-data-offset 5) temp0)
432    (cmpwi imm0 1)
433    (blt @loaded)
434    (bne @load-fp6-double)
435    (lfs fp6 0 temp1)
436    (la temp1 4 temp1)
437    (b @load-fp7)
438    @load-fp6-double
439    (lfd fp6 0 temp2)
440    (la temp2 8 temp2)
441    @load-fp7
442    (lbz imm0 (+ ppc32::misc-data-offset 6) temp0)
443    (cmpwi imm0 1)
444    (blt @loaded)
445    (bne @load-fp7-double)
446    (lfs fp7 0 temp1)
447    (la temp1 4 temp1)
448    (b @load-fp8)
449    @load-fp7-double
450    (lfd fp7 0 temp2)
451    (la temp2 8 temp2)
452    @load-fp8
453    (lbz imm0 (+ ppc32::misc-data-offset 0) temp0)
454    (cmpwi imm0 1)
455    (blt @loaded)
456    (bne @load-fp8-double)
457    (lfs fp8 0 temp1)
458    (b @loaded)
459    @load-fp8-double
460    (lfd fp8 0 temp2)
461    @loaded
462    (vpush buf)
463    (bla .SPeabi-ff-call)
464    (vpop buf)
465    (macptr-ptr imm2 buf)
466    (stw imm0 0 imm2)
467    (stw imm1 4 imm2)
468    (stfs fp1 8 imm2)
469    (stfd fp1 16 imm2)
470    (restore-full-lisp-context)
471    (li arg_z (target-nil-value))
472    (blr))
473 
474  (defun %ff-call (entry &rest specs-and-vals)
475    "Call the foreign function at address entrypoint passing the values of
476each arg as a foreign argument of type indicated by the corresponding
477arg-type-keyword. Returns the foreign function result (coerced to a Lisp
478object of type indicated by result-type-keyword), or NIL if
479result-type-keyword is :VOID or NIL"
480    (declare (dynamic-extent specs-and-vals))
481    (let* ((len (length specs-and-vals))
482           (other-offset 8)
483           (single-float-offset 8)
484           (double-float-offset 0)
485           (nsingle-floats 0)
486           (ndouble-floats 0)
487           (nother-words 0)
488           (nfpr-args 0)
489           (ngpr-args 0))
490      (declare (fixnum len  other-offset single-float-offset double-float-offset
491                       nsingle-floats ndouble-floats nother-words nfpr-args ngpr-args))
492      (unless (oddp len)
493        (error "Length of ~s is even.  Missing result ?" specs-and-vals))
494
495      (let* ((result-spec (or (car (last specs-and-vals)) :void))
496             (nargs (ash (the fixnum (1- len)) -1))
497             (fpr-reloads (make-array 8 :element-type '(unsigned-byte 8))))
498        (declare (fixnum nargs) (dynamic-extent fpr-reloads))
499        (do* ((i 0 (1+ i))
500              (specs specs-and-vals (cddr specs))
501              (spec (car specs) (car specs)))
502             ((= i nargs))
503          (declare (fixnum i))
504          (ecase spec
505            (:double-float (incf nfpr-args)
506                           (if (<= nfpr-args 8)
507                             (incf ndouble-floats)
508                             (progn
509                               (if (oddp nother-words)
510                                 (incf nother-words))
511                               (incf nother-words 2))))
512            (:single-float (incf nfpr-args)
513                           (if (<= nfpr-args 8)
514                             (incf nsingle-floats)
515                             (incf nother-words)))
516            ((:signed-doubleword :unsigned-doubleword)
517             (if (oddp ngpr-args)
518               (incf ngpr-args))
519             (incf ngpr-args 2)
520             (when (> ngpr-args 8)
521               (if (oddp nother-words)
522                 (incf nother-words))
523               (incf nother-words 2)))
524            ((:signed-byte :unsigned-byte :signed-halfword :unsigned-halfword
525                           :signed-fullword :unsigned-fullword :address)
526             (incf ngpr-args)
527             (if (> ngpr-args 8)
528               (incf nother-words)))))
529        (let* ((single-words (+ 8 nother-words nsingle-floats))
530               (total-words (if (zerop ndouble-floats)
531                              single-words
532                              (+ (the fixnum (+ ndouble-floats ndouble-floats))
533                                 (the fixnum (logand (lognot 1)
534                                                     (the fixnum (1+ single-words))))))))
535          (declare (fixnum total-words single-words))
536          (%stack-block
537              ((buf (ash total-words 2)))
538            (setq single-float-offset (+ other-offset nother-words))
539            (setq double-float-offset
540                  (logand (lognot 1)
541                          (the fixnum (1+ (the fixnum (+ single-float-offset nsingle-floats))))))
542           ;;; Make another pass through the arg/value pairs, evaluating each arg into
543           ;;; the buffer.
544            (do* ((i 0 (1+ i))
545                  (specs specs-and-vals (cddr specs))
546                  (spec (car specs) (car specs))
547                  (val (cadr specs) (cadr specs))
548                  (ngpr 0)
549                  (nfpr 0)
550                  (gpr-byte-offset 0)
551                  (other-byte-offset (ash other-offset 2))
552                  (single-byte-offset (ash single-float-offset 2))
553                  (double-byte-offset (ash double-float-offset 2)))
554                 ((= i nargs))
555              (declare (fixnum i gpr-byte-offset single-byte-offset double-byte-offset
556                               ngpr nfpr))
557              (case spec
558                (:double-float
559                 (cond ((< nfpr 8)
560                        (setf (uvref fpr-reloads nfpr) 2
561                              (%get-double-float buf double-byte-offset) val
562                              double-byte-offset (+ double-byte-offset 8)))
563                       (t
564                        (setq other-byte-offset (logand (lognot 7)
565                                                        (the fixnum (+ other-byte-offset 4))))
566                        (setf (%get-double-float buf other-byte-offset) val)
567                        (setq other-byte-offset (+ other-byte-offset 8))))
568                 (incf nfpr))
569                (:single-float
570                 (cond ((< nfpr 8)
571                        (setf (uvref fpr-reloads nfpr) 1
572                              (%get-single-float buf single-byte-offset) val
573                              single-byte-offset (+ single-byte-offset 4)))
574                             
575                       (t
576                        (setf (%get-single-float buf other-byte-offset) val
577                              other-byte-offset (+ other-byte-offset 4))))
578                 (incf nfpr))
579                (:address
580                 (cond ((< ngpr 8)
581                        (setf (%get-ptr buf gpr-byte-offset) val
582                              gpr-byte-offset (+ gpr-byte-offset 4)))
583                       (t
584                        (setf (%get-ptr buf other-byte-offset) val
585                              other-byte-offset (+ other-byte-offset 4))))
586                 (incf ngpr))
587                ((:signed-doubleword :unsigned-doubleword)
588                 (when (oddp ngpr)
589                   (incf ngpr)
590                   (incf gpr-byte-offset 4))
591                 (cond ((< ngpr 8)
592                        (if (eq spec :signed-doubleword)
593                          (setf (%get-signed-long-long buf gpr-byte-offset) val)
594                          (setf (%get-unsigned-long-long buf gpr-byte-offset) val))
595                        (incf gpr-byte-offset 8))
596                       (t
597                        (when (logtest other-byte-offset 7)
598                          (incf other-byte-offset 4))
599                        (if (eq spec :signed-doubleword)
600                          (setf (%get-signed-long-long buf other-byte-offset) val)
601                          (setf (%get-unsigned-long-long buf other-byte-offset) val))
602                        (incf other-byte-offset 8)))
603                 (incf ngpr 2))
604                (t
605                 (cond ((< ngpr 8)
606                        (setf (%get-long buf gpr-byte-offset) val
607                              gpr-byte-offset (+ gpr-byte-offset 4)))
608                       (t
609                        (setf (%get-long buf other-byte-offset) val
610                              other-byte-offset (+ other-byte-offset 4))))
611                 (incf ngpr))))
612            (%%ff-call fpr-reloads
613                       single-float-offset
614                       double-float-offset
615                       (the fixnum (-
616                                    (ash (the fixnum
617                                           (+ 6
618                                              (the fixnum (logand
619                                                           (lognot 1)
620                                                           (the fixnum (1+ total-words))))))
621                                         2)))
622                       buf
623                       entry)
624            (ecase result-spec
625              (:void nil)
626              (:single-float (%get-single-float buf 8))
627              (:double-float (%get-double-float buf 16))
628              (:address (%get-ptr buf))
629              (:signed-doubleword (%get-signed-long-long buf 0))
630              (:unsigned-doubleword (%get-unsigned-long-long buf 0))
631              (:signed-fullword (%get-signed-long buf))
632              (:unsigned-fullword (%get-unsigned-long buf))
633              (:signed-halfword (%get-signed-word buf 2))
634              (:unsigned-halfword (%get-unsigned-word buf 2))
635              (:signed-byte (%get-signed-byte buf 3))
636              (:unsigned-byte (%get-unsigned-byte buf 3))))))))
637  )
638
639
640
641
642
643;;; In the PowerOpen ABI, all arguments are passed in a contiguous
644;;; block.  The first 13 (!) FP args are passed in FP regs; doubleword
645;;; arguments are aligned on word boundaries.
646#+poweropen-target
647(progn
648  #+ppc32-target
649  (progn
650    (defun %ff-call (entry &rest specs-and-vals)
651      (declare (dynamic-extent specs-and-vals))
652      (let* ((len (length specs-and-vals))
653             (total-words 0))
654        (declare (fixnum len total-words))
655        (unless (oddp len)
656          (error "Length of ~s is even.  Missing result ?" specs-and-vals))
657        (let* ((result-spec (or (car (last specs-and-vals)) :void))
658               (nargs (ash (the fixnum (1- len)) -1))
659               (fpr-reload-sizes (make-array 13 :element-type '(unsigned-byte 8)))
660               (fpr-reload-offsets (make-array 13 :element-type '(unsigned-byte 16))))
661          (declare (fixnum nargs) (dynamic-extent fpr-reload-sizes fpr-reload-offsets))
662          (do* ((i 0 (1+ i))
663                (specs specs-and-vals (cddr specs))
664                (spec (car specs) (car specs)))
665               ((= i nargs))
666            (declare (fixnum i))
667            (case spec
668              ((:double-float :signed-doubleword :unsigned-doubleword)
669               (incf total-words 2))
670              ((:single-float :signed-byte :unsigned-byte :signed-halfword
671                              :unsigned-halfword :signed-fullword
672                              :unsigned-fullword :address)
673               (incf total-words))
674              (t (if (typep spec 'unsigned-byte)
675                   (incf total-words spec)
676                   (error "Invalid argument spec ~s" spec)))))
677          (%stack-block ((buf (ash (logand (lognot 1) (1+ (max 6  total-words))) 2)))
678            (do* ((i 0 (1+ i))
679                  (fpr 0)
680                  (offset 0 (+ offset 4))
681                  (specs specs-and-vals (cddr specs))
682                  (spec (car specs) (car specs))
683                  (val (cadr specs) (cadr specs)))
684                 ((= i nargs))
685              (declare (fixnum i offset fpr))
686              (case spec
687                (:double-float
688                 (when (< fpr 13)
689                   (setf (uvref fpr-reload-sizes fpr) 2
690                         (uvref fpr-reload-offsets fpr) offset))
691                 (incf fpr)
692                 (setf (%get-double-float buf offset) val)
693                 (incf offset 4))
694                (:single-float
695                 (when (< fpr 13)
696                   (setf (uvref fpr-reload-sizes fpr) 1
697                         (uvref fpr-reload-offsets fpr) offset))
698                 (incf fpr)
699                 (setf (%get-single-float buf offset) val))
700                (:signed-doubleword
701                 (setf (%get-signed-long-long buf offset) val)
702                 (incf offset 4))
703                (:unsigned-doubleword
704                 (setf (%get-unsigned-long-long buf offset) val)
705                 (incf offset 4))
706                (:address
707                 (setf (%get-ptr buf offset) val))
708                (t
709                 (if (typep spec 'unsigned-byte)
710                   (dotimes (i spec (decf offset 4))
711                     (setf (%get-ptr buf offset)
712                           (%get-ptr val (* i 4)))
713                     (incf offset 4))
714                   (setf (%get-long buf offset) val)))))
715            (let* ((frame-size (if (<= total-words 8)
716                                 (ash
717                                  (+ ppc32::c-frame.size ppc32::lisp-frame.size)
718                                  -2)
719                                 (+
720                                  (ash
721                                   (+ ppc32::c-frame.size ppc32::lisp-frame.size)
722                                   -2)
723                                  (logand (lognot 1)
724                                          (1+ (- total-words 8)))))))
725             
726              (%%ff-call
727               fpr-reload-sizes
728               fpr-reload-offsets
729               (- (logandc2 (+ frame-size 3) 3))
730               total-words
731               buf
732               entry))
733            (ecase result-spec
734              (:void nil)
735              (:single-float (%get-single-float buf 8))
736              (:double-float (%get-double-float buf 16))
737              (:address (%get-ptr buf))
738              (:signed-doubleword (%get-signed-long-long buf 0))
739              (:unsigned-doubleword (%get-unsigned-long-long buf 0))
740              (:signed-fullword (%get-signed-long buf))
741              (:unsigned-fullword (%get-unsigned-long buf))
742              (:signed-halfword (%get-signed-word buf 2))
743              (:unsigned-halfword (%get-unsigned-word buf 2))
744              (:signed-byte (%get-signed-byte buf 3))
745              (:unsigned-byte (%get-unsigned-byte buf 3)))))))
746
747
748    (defppclapfunction %%ff-call ((reload-sizes 8)
749                                  (reload-offsets 4)
750                                  (frame-size 0)                             
751                                  (total-words arg_x)
752                                  (buf arg_y)
753                                  (entry arg_z))
754      (check-nargs 6)
755      (la imm0 12 vsp)
756      (save-lisp-context imm0)
757      (lwz imm0 frame-size vsp)
758      (stwux sp sp imm0)
759      (stw sp ppc32::c-frame.savelr sp)
760      (macptr-ptr imm2 buf)
761      (mr imm1 imm2)
762      (la imm3 ppc32::c-frame.param0 sp)
763      (li temp1 0)
764      @copy
765      (addi temp1 temp1 '1)
766      (cmpw temp1 total-words)
767      (lwz imm0 0 imm2)
768      (la imm2 4 imm2)
769      (stw imm0 0 imm3)
770      (la imm3 4 imm3)
771      (blt @copy)
772      (lwz temp0 reload-sizes vsp)
773      (lwz temp1 reload-offsets vsp)
774      @load-fp1
775      (lbz imm0 (+ ppc32::misc-data-offset 0) temp0)
776      (cmpwi imm0 1)
777      (lhz imm2 (+ ppc32::misc-data-offset 0) temp1)
778      (blt @loaded)
779      (bne @load-fp1-double)
780      (lfsx fp1 imm1 imm2)
781      (b @load-fp2)
782      @load-fp1-double
783      (lfdx fp1 imm1 imm2)
784
785      @load-fp2
786      (lbz imm0 (+ ppc32::misc-data-offset 1) temp0)
787      (cmpwi imm0 1)
788      (lhz imm2 (+ ppc32::misc-data-offset 2) temp1)
789      (blt @loaded)
790      (bne @load-fp2-double)
791      (lfsx fp2 imm1 imm2)
792      (b @load-fp3)
793      @load-fp2-double
794      (lfdx fp2 imm1 imm2)
795
796      @load-fp3
797      (lbz imm0 (+ ppc32::misc-data-offset 2) temp0)
798      (cmpwi imm0 1)
799      (lhz imm2 (+ ppc32::misc-data-offset 4) temp1)
800      (blt @loaded)
801      (bne @load-fp3-double)
802      (lfsx fp3 imm1 imm2)
803      (b @load-fp4)
804      @load-fp3-double
805      (lfdx fp3 imm1 imm2)
806
807      @load-fp4
808      (lbz imm0 (+ ppc32::misc-data-offset 3) temp0)
809      (cmpwi imm0 1)
810      (lhz imm2 (+ ppc32::misc-data-offset 6) temp1)
811      (blt @loaded)
812      (bne @load-fp4-double)
813      (lfsx fp4 imm1 imm2)
814      (b @load-fp5)
815      @load-fp4-double
816      (lfdx fp4 imm1 imm2)
817
818      @load-fp5
819      (lbz imm0 (+ ppc32::misc-data-offset 4) temp0)
820      (cmpwi imm0 1)
821      (lhz imm2 (+ ppc32::misc-data-offset 8) temp1)
822      (blt @loaded)
823      (bne @load-fp5-double)
824      (lfsx fp5 imm1 imm2)
825      (b @load-fp6)
826      @load-fp5-double
827      (lfdx fp5 imm1 imm2)
828
829      @load-fp6
830      (lbz imm0 (+ ppc32::misc-data-offset 5) temp0)
831      (cmpwi imm0 1)
832      (lhz imm2 (+ ppc32::misc-data-offset 10) temp1)
833      (blt @loaded)
834      (bne @load-fp1-double)
835      (lfsx fp6 imm1 imm2)
836      (b @load-fp7)
837      @load-fp6-double
838      (lfdx fp6 imm1 imm2)
839
840      @load-fp7
841      (lbz imm0 (+ ppc32::misc-data-offset 6) temp0)
842      (cmpwi imm0 1)
843      (lhz imm2 (+ ppc32::misc-data-offset 12) temp1)
844      (blt @loaded)
845      (bne @load-fp1-double)
846      (lfsx fp7 imm1 imm2)
847      (b @load-fp8)
848      @load-fp7-double
849      (lfdx fp7 imm1 imm2)
850
851      @load-fp8
852      (lbz imm0 (+ ppc32::misc-data-offset 7) temp0)
853      (cmpwi imm0 1)
854      (lhz imm2 (+ ppc32::misc-data-offset 14) temp1)
855      (blt @loaded)
856      (bne @load-fp8-double)
857      (lfsx fp8 imm1 imm2)
858      (b @load-fp9)
859      @load-fp8-double
860      (lfdx fp8 imm1 imm2)
861
862      @load-fp9
863      (lbz imm0 (+ ppc32::misc-data-offset 8) temp0)
864      (cmpwi imm0 1)
865      (lhz imm2 (+ ppc32::misc-data-offset 16) temp1)
866      (blt @loaded)
867      (bne @load-fp9-double)
868      (lfsx fp9 imm1 imm2)
869      (b @load-fp10)
870      @load-fp9-double
871      (lfdx fp9 imm1 imm2)
872
873      @load-fp10
874      (lbz imm0 (+ ppc32::misc-data-offset 9) temp0)
875      (cmpwi imm0 1)
876      (lhz imm2 (+ ppc32::misc-data-offset 18) temp1)
877      (blt @loaded)
878      (bne @load-fp10-double)
879      (lfsx fp10 imm1 imm2)
880      (b @load-fp11)
881      @load-fp10-double
882      (lfdx fp10 imm1 imm2)
883
884      @load-fp11
885      (lbz imm0 (+ ppc32::misc-data-offset 10) temp0)
886      (cmpwi imm0 1)
887      (lhz imm2 (+ ppc32::misc-data-offset 20) temp1)
888      (blt @loaded)
889      (bne @load-fp11-double)
890      (lfsx fp11 imm1 imm2)
891      (b @load-fp12)
892      @load-fp11-double
893      (lfdx fp11 imm1 imm2)
894
895      @load-fp12
896      (lbz imm0 (+ ppc32::misc-data-offset 11) temp0)
897      (cmpwi imm0 1)
898      (lhz imm2 (+ ppc32::misc-data-offset 22) temp1)
899      (blt @loaded)
900      (bne @load-fp12-double)
901      (lfsx fp12 imm1 imm2)
902      (b @load-fp13)
903      @load-fp12-double
904      (lfdx fp12 imm1 imm2)
905
906      @load-fp13
907      (lbz imm0 (+ ppc32::misc-data-offset 12) temp0)
908      (cmpwi imm0 1)
909      (lhz imm2 (+ ppc32::misc-data-offset 24) temp1)
910      (blt @loaded)
911      (bne @load-fp13-double)
912      (lfsx fp13 imm1 imm2)
913      (b @loaded)
914      @load-fp13-double
915      (lfdx fp13 imm1 imm2)
916      @loaded
917      (vpush buf)
918      (bla .SPpoweropen-ffcall)
919      @called
920      (vpop buf)
921      (macptr-ptr imm2 buf)
922      (stw imm0 0 imm2)
923      (stw imm1 4 imm2)
924      (stfs fp1 8 imm2)
925      (stfd fp1 16 imm2)
926      (restore-full-lisp-context)
927      (li arg_z (target-nil-value))
928      (blr))
929    )
930
931  #+ppc64-target
932  (progn
933  ;;; There are a few funky, non-obvious things going on here.
934  ;;; The main %FF-CALL function uses WITH-VARIABLE-C-FRAME;
935  ;;; the compiler will generate code to pop that frame off
936  ;;; of the C/control stack, but the subprim that implements
937  ;;; %ff-call has already popped it off.  To put things back
938  ;;; in balance, the LAP function %%FF-RESULT pushes an
939  ;;; extra frame on the cstack.
940  ;;; %FF-CALL calls %%FF-RESULT to box the result, which may
941  ;;; be in r3/imm0 or in fp1.  It's critical that the call
942  ;;; to %%FF-RESULT not be compiled as "multiple-value returning",
943  ;;; since the MV machinery may clobber IMM0.
944    (defppclapfunction %%ff-result ((spec arg_z))
945      (stdu sp -160 sp)
946      (ld arg_y ':void nfn)
947      (cmpd cr0 spec arg_y)
948      (ld arg_x ':address nfn)
949      (cmpd cr1 spec arg_x)
950      (ld temp3 ':single-float nfn)
951      (cmpd cr2 spec temp3)
952      (ld arg_y ':double-float nfn)
953      (cmpd cr3 spec arg_y)
954      (ld arg_x ':unsigned-doubleword nfn)
955      (cmpd cr4 spec arg_x)
956      (ld temp3 ':signed-doubleword nfn)
957      (cmpd cr5 spec temp3)
958      (beq cr0 @void)
959      (beq cr1 @address)
960      (beq cr2 @single-float)
961      (beq cr3 @double-float)
962      (beq cr4 @unsigned-doubleword)
963      (beq cr5 @signed-doubleword)
964      (box-fixnum arg_z imm0)
965      (blr)
966      @void
967      (li arg_z nil)
968      (blr)
969      @address
970      (li imm1 ppc64::macptr-header)
971      (subi allocptr allocptr (- ppc64::macptr.size ppc64::fulltag-misc))
972      (tdlt allocptr allocbase)
973      (std imm1 ppc64::misc-header-offset allocptr)
974      (mr arg_z allocptr)
975      (clrrdi allocptr allocptr 4)
976      (std imm0 ppc64::macptr.address arg_z)
977      (blr)
978      @single-float
979      (put-single-float fp1 arg_z)
980      (blr)
981      @double-float
982      (li imm1 ppc64::double-float-header)
983      (subi allocptr allocptr (- ppc64::double-float.size ppc64::fulltag-misc))
984      (tdlt allocptr allocbase)
985      (std imm1 ppc64::misc-header-offset allocptr)
986      (mr arg_z allocptr)
987      (clrrdi allocptr allocptr 4)
988      (stfd fp1 ppc64::macptr.address arg_z)
989      (blr)
990      @unsigned-doubleword
991      (ba .SPmakeu64)
992      @signed-doubleword
993      (ba .SPmakes64))
994
995  ;;; This is just here so that we can jump to a subprim from lisp.
996    (defppclapfunction %do-ff-call ((regbuf arg_y) (entry arg_z))
997      (cmpdi cr0 regbuf nil)
998      (bnea cr0 .SPpoweropen-ffcall-return-registers)
999      (ba .SPpoweropen-ffcall))
1000 
1001    (defun %ff-call (entry &rest specs-and-vals)
1002      (declare (dynamic-extent specs-and-vals))
1003      (let* ((len (length specs-and-vals))
1004             (total-words 0)
1005             (registers nil))
1006        (declare (fixnum len total-words))
1007        (let* ((result-spec (or (car (last specs-and-vals)) :void))
1008               (nargs (ash (the fixnum (1- len)) -1)))
1009          (declare (fixnum nargs))
1010          (ecase result-spec
1011            ((:address :unsigned-doubleword :signed-doubleword
1012                       :single-float :double-float
1013                       :signed-fullword :unsigned-fullword
1014                       :signed-halfword :unsigned-halfword
1015                       :signed-byte :unsigned-byte
1016                       :void)
1017             (do* ((i 0 (1+ i))
1018                   (specs specs-and-vals (cddr specs))
1019                   (spec (car specs) (car specs)))
1020                  ((= i nargs))
1021               (declare (fixnum i))
1022               (case spec
1023                 (:registers nil)
1024                 ((:address :unsigned-doubleword :signed-doubleword
1025                            :single-float :double-float
1026                            :signed-fullword :unsigned-fullword
1027                            :signed-halfword :unsigned-halfword
1028                            :signed-byte :unsigned-byte
1029                            :hybrid-int-float :hybrid-float-float
1030                            :hybrid-float-int)
1031                  (incf total-words))
1032                 (t (if (typep spec 'unsigned-byte)
1033                      (incf total-words spec)
1034                      (error "unknown arg spec ~s" spec)))))
1035             (%stack-block ((fp-args (* 13 8)))
1036               (with-variable-c-frame
1037                   total-words frame
1038                   (with-macptrs ((argptr))
1039                     (%setf-macptr-to-object argptr frame)
1040                     (let* ((offset ppc64::c-frame.param0)
1041                            (n-fp-args 0))
1042                       (declare (fixnum offset n-fp-args))
1043                       (do* ((i 0 (1+ i))
1044                             (specs specs-and-vals (cddr specs))
1045                             (spec (car specs) (car specs))
1046                             (val (cadr specs) (cadr specs)))
1047                            ((= i nargs))
1048                         (declare (fixnum i))
1049                         (case spec
1050                           (:registers (setq registers val))
1051                           (:address (setf (%get-ptr argptr offset) val)
1052                                     (incf offset 8))
1053                           ((:signed-doubleword :signed-fullword :signed-halfword
1054                                                :signed-byte)
1055                         
1056                            (setf (%%get-signed-longlong argptr offset) val)
1057                            (incf offset 8))
1058                           ((:unsigned-doubleword :unsigned-fullword :unsigned-halfword
1059                                                  :unsigned-byte)
1060                            (setf (%%get-unsigned-longlong argptr offset) val)
1061                            (incf offset 8))
1062                           (:hybrid-int-float
1063                            (setf (%%get-unsigned-longlong argptr offset) val)
1064                            (when (< n-fp-args 13)
1065                              (setf (%get-double-float fp-args (* n-fp-args 8))
1066                                    (%double-float (%get-single-float argptr (+ offset 4)))))
1067                            (incf n-fp-args)
1068                            (incf offset 8))
1069                           (:hybrid-float-int
1070                            (setf (%%get-unsigned-longlong argptr offset) val)
1071                            (when (< n-fp-args 13)
1072                              (setf (%get-double-float fp-args (* n-fp-args 8))
1073                                    (%double-float (%get-single-float argptr offset))))
1074                            (incf n-fp-args)
1075                            (incf offset 8))
1076                           (:hybrid-float-float
1077                            (setf (%%get-unsigned-longlong argptr offset) val)
1078                            (when (< n-fp-args 13)
1079                              (setf (%get-double-float fp-args (* n-fp-args 8))
1080                                    (%double-float (%get-single-float argptr offset))))
1081                            (incf n-fp-args)
1082                            (when (< n-fp-args 13)
1083                              (setf (%get-double-float fp-args (* n-fp-args 8))
1084                                    (%double-float (%get-single-float argptr (+ offset 4)))))
1085                            (incf n-fp-args)
1086                            (incf offset 8))
1087                           (:double-float
1088                            (setf (%get-double-float argptr offset) val)
1089                            (when (< n-fp-args 13)
1090                              (setf (%get-double-float fp-args (* n-fp-args 8)) val))
1091                            (incf n-fp-args)
1092                            (incf offset 8))
1093                           (:single-float
1094                            (setf (%get-single-float argptr offset) val)
1095                            (when (< n-fp-args 13)
1096                              (setf (%get-double-float fp-args (* n-fp-args 8))
1097                                    (%double-float val)))
1098                            (incf n-fp-args)
1099                            (incf offset 8))
1100                           (t
1101                            (let* ((p 0))
1102                              (declare (fixnum p))
1103                              (dotimes (i (the fixnum spec))
1104                                (setf (%get-ptr argptr offset) (%get-ptr val p))
1105                                (incf p 8)
1106                                (incf offset 8))))))
1107                       (%load-fp-arg-regs n-fp-args fp-args)
1108                       (%do-ff-call registers entry)
1109                       (values (%%ff-result result-spec)))))))))))
1110
1111    )
1112  )
1113
1114
1115
1116(defppclapfunction %get-object ((macptr arg_y) (offset arg_z))
1117  (check-nargs 2)
1118  (trap-unless-typecode= arg_y target::subtag-macptr)
1119  (macptr-ptr imm0 arg_y)
1120  (trap-unless-lisptag= arg_z target::tag-fixnum imm1)
1121  (unbox-fixnum imm1 arg_z)
1122  (ldrx arg_z imm0 imm1)
1123  (blr))
1124
1125
1126(defppclapfunction %set-object ((macptr arg_x) (offset arg_y) (value arg_z))
1127  (check-nargs 3)
1128  (trap-unless-typecode= arg_x target::subtag-macptr)
1129  (macptr-ptr imm0 arg_x)
1130  (trap-unless-lisptag= arg_y target::tag-fixnum imm1)
1131  (unbox-fixnum imm1 arg_y)
1132  (strx arg_z imm0 imm1)
1133  (blr))
1134
1135
1136(defppclapfunction %apply-lexpr-with-method-context ((magic arg_x)
1137                                                     (function arg_y)
1138                                                     (args arg_z))
1139  ;; Somebody's called (or tail-called) us.
1140  ;; Put magic arg in ppc::next-method-context (= ppc::temp1).
1141  ;; Put function in ppc::nfn (= ppc::temp2).
1142  ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
1143  ;;   but preserves ppc::nfn/ppc::next-method-context.
1144  ;; Jump to the function in ppc::nfn.
1145  (mr ppc::next-method-context magic)
1146  (mr ppc::nfn function)
1147  (set-nargs 0)
1148  (mflr loc-pc)
1149  (bla .SPspread-lexpr-z)
1150  (mtlr loc-pc)
1151  (ldr temp0 target::misc-data-offset nfn)
1152  (mtctr temp0)
1153  (bctr))
1154
1155
1156(defppclapfunction %apply-with-method-context ((magic arg_x)
1157                                               (function arg_y)
1158                                               (args arg_z))
1159  ;; Somebody's called (or tail-called) us.
1160  ;; Put magic arg in ppc::next-method-context (= ppc::temp1).
1161  ;; Put function in ppc::nfn (= ppc::temp2).
1162  ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
1163  ;;   but preserves ppc::nfn/ppc::next-method-context.
1164  ;; Jump to the function in ppc::nfn.
1165  (mr ppc::next-method-context magic)
1166  (mr ppc::nfn function)
1167  (set-nargs 0)
1168  (mflr loc-pc)
1169  (bla .SPspreadargZ)
1170  (mtlr loc-pc)
1171  (ldr temp0 target::misc-data-offset nfn)
1172  (mtctr temp0)
1173  (bctr))
1174
1175
1176
1177
1178(defppclapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z))
1179  ;; This assumes
1180  ;; a) that "args" is a lexpr made via the .SPlexpr-entry mechanism
1181  ;; b) That the LR on entry to this function points to the lexpr-cleanup
1182  ;;    code that .SPlexpr-entry set up
1183  ;; c) That there weren't any required args to the lexpr, e.g. that
1184  ;;    (%lexpr-ref args (%lexpr-count args) 0) was the first arg to the gf.
1185  ;; The lexpr-cleanup code will be EQ to either (lisp-global ret1valaddr)
1186  ;; or (lisp-global lexpr-return1v).  In the former case, discard a frame
1187  ;; from the cstack (multiple-value tossing).  Restore FN and LR from
1188  ;; the first frame that .SPlexpr-entry pushed, restore vsp from (+
1189  ;; args node-size), pop the argregs, and jump to the function.
1190  (mflr loc-pc)
1191  (ref-global imm0 ret1valaddr)
1192  (cmpr cr2 loc-pc imm0)
1193  (ldr nargs 0 args)
1194  (mr imm5 nargs)
1195  (cmpri cr0 nargs 0)
1196  (cmpri cr1 nargs '2)
1197  (mr nfn method)
1198  (ldr temp0 target::misc-data-offset nfn)
1199  (mtctr temp0)
1200  (if (:cr2 :eq)
1201    (la sp target::lisp-frame.size sp))
1202  (ldr loc-pc target::lisp-frame.savelr sp)
1203  (ldr fn target::lisp-frame.savefn sp)
1204  (ldr imm0 target::lisp-frame.savevsp sp)
1205  (sub vsp imm0 nargs)
1206  (mtlr loc-pc)
1207  (la sp target::lisp-frame.size sp)
1208  (beqctr)
1209  (vpop arg_z)
1210  (bltctr cr1)
1211  (vpop arg_y)
1212  (beqctr cr1)
1213  (vpop arg_x)
1214  (bctr))
1215
1216
1217(defun %copy-function (proto &optional target)
1218  (let* ((total-size (uvsize proto))
1219         (new (or target (allocate-typed-vector :function total-size))))
1220    (declare (fixnum total-size))
1221    (when target
1222      (unless (eql total-size (uvsize target))
1223        (error "Wrong size target ~s" target)))
1224    (%copy-gvector-to-gvector proto 0 new 0 total-size)
1225    new))
1226
1227(defun replace-function-code (target-fn proto-fn)
1228  (if (typep target-fn 'function)
1229    (if (typep proto-fn 'function)
1230      (setf (uvref target-fn 0)
1231            (uvref proto-fn 0))
1232      (report-bad-arg proto-fn 'function))
1233    (report-bad-arg target-fn 'function)))
1234
1235(defun closure-function (fun)
1236  (while (and (functionp fun)  (not (compiled-function-p fun)))
1237    (setq fun (%svref fun 1))
1238    (when (vectorp fun)
1239      (setq fun (svref fun 0))))
1240  fun)
1241
1242
1243;;; For use by (setf (apply ...) ...)
1244;;; (apply+ f butlast last) = (apply f (append butlast (list last)))
1245#+ppc-target
1246(defun apply+ (&lap function arg1 arg2 &rest other-args)
1247  (ppc-lap-function apply+ ()
1248   (check-nargs 3 nil)
1249   (vpush arg_x)
1250   (mr temp0 arg_z)                     ; last
1251   (mr arg_z arg_y)                     ; butlast
1252   (subi nargs nargs '2)                ; remove count for butlast & last
1253   (mflr loc-pc)
1254   (bla .SPspreadargz)
1255   (cmpri cr0 nargs '3)
1256   (mtlr loc-pc)
1257   (addi nargs nargs '1)                ; count for last
1258   (blt cr0 @nopush)
1259   (vpush arg_x)
1260@nopush
1261   (mr arg_x arg_y)
1262   (mr arg_y arg_z)
1263   (mr arg_z temp0)
1264   (ldr temp0 'funcall nfn)
1265   (ba .SPfuncall)))
1266
1267(lfun-bits #'apply+ (logior $lfbits-rest-bit
1268                            (dpb 3 $lfbits-numreq 0)))
1269
1270;;; end of ppc-def.lisp
Note: See TracBrowser for help on using the repository browser.