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

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

Don't use "ba" pseudo-instruction.

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