source: branches/arm/level-0/ARM/arm-def.lisp @ 14073

Last change on this file since 14073 was 14073, checked in by gb, 10 years ago

APPLY+: just restore lr from saved lisp frame.

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