source: trunk/source/level-0/ARM/arm-def.lisp @ 15601

Last change on this file since 15601 was 15431, checked in by gb, 7 years ago

lib/macros.lisp: DEFCALLBACK-BODY expands into LET*, not LET. (Matters

on ARM, likely doesn't for other architectures.)

compiler/ARM/arm2.lisp: unsafe optimization in ARM2-GET-FLOAT.
compiler/ARM/arm-backend.lisp: handle hard-float conventions in callbacks

on ARM. Fixes ticket:1000

level-0/ARM/arm-def.lisp: in %FF-CALL-HARD-FLOAT, don't preincrement

FP-ARG-OFFSET in the :SINGLE-FLOAT case.

File size: 26.1 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(defarmlapfunction %fix-fn-entrypoint ((func arg_z))
20  (build-lisp-frame imm0)
21  (ldr temp0 (:@ func (:$  arm::function.codevector)))
22  (add lr temp0 (:$ arm::misc-data-offset))
23  (str lr (:@ func (:$ arm::function.entrypoint)))
24  (return-lisp-frame imm0))
25
26;;; Do an FF-CALL to MakeDataExecutable so that the data cache gets flushed.
27;;; If the GC moves this function while we're trying to flush the cache,
28;;; it'll flush the cache: no harm done in that case.
29
30(defun %make-code-executable (codev)
31  (with-macptrs (p)
32    (let* ((nbytes (ash (uvsize codev) arm::word-shift)))
33      (%vect-data-to-macptr codev p)
34      (ff-call (%kernel-import arm::kernel-import-MakeDataExecutable)
35               :address p
36               :unsigned-fullword nbytes
37               :void))))
38
39(defarmlapfunction %get-kernel-global-from-offset ((offset arg_z))
40  (check-nargs 1)
41  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
42  (ldr arg_z (:-@ imm0 (:asr offset (:$ arm::fixnumshift))))
43  (bx lr))
44
45
46(defarmlapfunction %set-kernel-global-from-offset ((offset arg_y) (new-value arg_z))
47  (check-nargs 2)
48  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
49  (ldr new-value (:-@ imm0 (:asr offset (:$ arm::fixnumshift))))
50  (bx lr))
51
52
53
54(defarmlapfunction %get-kernel-global-ptr-from-offset ((offset arg_y)
55                                                       (ptr arg_z))
56  (check-nargs 2)
57  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
58  (ldr imm0 (:-@ imm0 (:asr offset (:$ arm::fixnumshift))))
59  (str imm0 (:@ ptr (:$ target::macptr.address)))
60  (bx lr))
61
62
63
64
65(defarmlapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z))
66  (:arglist (fixnum &optional offset))
67  (check-nargs 1 2)
68  (cmp nargs '1)
69  (moveq fixnum offset)
70  (moveq offset (:$ 0))
71  (unbox-fixnum imm0 offset)
72  (ldr arg_z (:@ imm0 fixnum))
73  (bx lr))
74
75
76(defarmlapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z))
77  (:arglist (fixnum &optional offset))
78  (check-nargs 1 2)
79  (cmp nargs '1)
80  (moveq fixnum offset)
81  (moveq offset (:$ 0))
82  (unbox-fixnum imm0 offset)
83  (ldr imm0 (:@ imm0 fixnum))
84  (spjump .SPmakeu32))
85
86
87
88(defarmlapfunction %fixnum-set ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z))
89  (:arglist (fixnum offset &optional new-value))
90  (check-nargs 2 3)
91  (cmp nargs '2)
92  (moveq fixnum offset)
93  (moveq offset (:$ 0))
94  (unbox-fixnum imm0 offset)
95  (str new-value (:@ imm0 fixnum))
96  (mov arg_z new-value)
97  (bx lr))
98
99(defarmlapfunction %fixnum-set-natural ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z))
100  (check-nargs 2 3)
101  (cmp nargs '2)
102  (moveq fixnum offset)
103  (moveq offset (:$ 0))
104  (unbox-fixnum imm0 offset)
105  (test-fixnum new-value)
106  (unbox-fixnum imm2 new-value)
107  (beq @store)
108  (extract-subtag imm1 new-value)
109  (cmp imm1 (:$ arm::subtag-bignum))
110  (beq @ok1)
111  (uuo-error-reg-not-xtype new-value (:$ arm::xtype-u32))
112  @ok1
113  (getvheader imm0 new-value)
114  (header-length temp0 imm0)
115  (cmp temp0 '2)
116  (ldr imm2 (:@ new-value (:$ arm::misc-data-offset)))
117  (ldreq imm1 (:@ new-value (:$ (+ arm::misc-data-offset))))
118  (ble @ok2)
119  (uuo-error-reg-not-xtype new-value (:$ arm::xtype-u32))
120  @ok2
121  (bne @one)
122  (cmp imm1 (:$ 0))
123  (beq @store)
124  (uuo-error-reg-not-xtype new-value (:$ arm::xtype-u32))
125  @one
126  (cmp imm2 (:$ 0))
127  (bge @store)
128  (uuo-error-reg-not-xtype new-value (:$ arm::xtype-u32))
129  @store
130  (str imm2 (:@ imm0 fixnum))
131  (mov arg_z new-value)
132  (bx lr))
133
134
135
136(defarmlapfunction %current-frame-ptr ()
137  (check-nargs 0)
138  (mov arg_z sp)
139  (bx lr))
140
141(defarmlapfunction %current-vsp ()
142  (check-nargs 0)
143  (mov arg_z vsp)
144  (bx lr))
145
146
147
148
149(defarmlapfunction %set-current-vsp ((new-vsp arg_z))
150  (check-nargs 1)
151  (mov vsp new-vsp)
152  (bx lr))
153
154
155
156(defarmlapfunction %%frame-backlink ((p arg_z))
157  (check-nargs 1)
158  (ldr imm0 (:@ p))
159  (cmp imm0 (:$ arm::lisp-frame-marker))
160  (addeq arg_z p (:$ arm::lisp-frame.size))
161  (bxeq lr)
162  (cmp imm0 (:$ arm::stack-alloc-marker))
163  (and imm1 imm0 (:$ arm::fulltagmask))
164  (addeq arg_z p '2)
165  (bxeq lr)
166  (cmp imm1 (:$ arm::fulltag-immheader))
167  (beq @imm)
168  (cmp imm1 (:$ arm::fulltag-nodeheader))
169  (movne arg_z (:$ 0))
170  (bxne lr)
171  (header-length imm0 imm0)
172 
173  (add imm0 imm0 (:$ (* 2 arm::node-size)))
174  (bic imm0 imm0 (:$ arm::node-size))
175  (add arg_z p imm0)
176  (bx lr)
177  @imm
178  (extract-lowbyte imm1 imm0)
179  (mov imm0 (:lsr imm0 (:$ arm::num-subtag-bits)))
180  (cmp imm1 (:$ arm::max-32-bit-ivector-subtag))
181  (bhi @8)
182  (mov imm0 (:lsl imm0 (:$ arm::word-shift)))
183  @align
184  (add imm0 imm0 (:$ (+ 4 7)))
185  (bic imm0 imm0 (:$ arm::fulltagmask))
186  (add arg_z p imm0)
187  (bx lr)
188  @8
189  (cmp imm1 (:$ arm::max-8-bit-ivector-subtag))
190  (bls @align)
191  (cmp imm1 (:$ arm::max-16-bit-ivector-subtag))
192  (movls imm0 (:lsl imm0 (:$ 1)))
193  (bls @align)
194  (cmp imm1 (:$ arm::subtag-double-float-vector))
195  (moveq imm0 (:lsl imm0 (:$ 3)))
196  (beq @align)
197  (add imm0 imm0 (:$ 7))
198  (mov imm0 (:lsr imm0 (:$ 3)))
199  (b @align))
200 
201 
202 
203
204
205
206
207
208(defarmlapfunction %%frame-savefn ((p arg_z))
209  (check-nargs 1)
210  (ldr arg_z (:@ arg_z (:$ arm::lisp-frame.savefn)))
211  (bx lr))
212
213(defarmlapfunction %cfp-lfun ((p arg_z))
214  (build-lisp-frame)
215  (ldr arg_y (:@ p (:$ arm::lisp-frame.savefn)))
216  (extract-typecode imm0 arg_y)
217  (cmp imm0 (:$ arm::subtag-function))
218  (ldr lr (:@ p (:$ arm::lisp-frame.savelr)))
219  (bne @no)
220  (ldr arg_x (:@ arg_y (:$ (+ arm::node-size arm::misc-data-offset))))
221  (sub imm1 lr arg_x)
222  (add imm1 imm1 (:$ (- arm::misc-data-offset)))
223  (getvheader imm0 arg_x)
224  (header-length imm0 imm0)
225  (cmp imm1 imm0)
226  (box-fixnum imm1 imm1)
227  (bhs @no)
228  (vpush1 arg_y)
229  (vpush1 imm1)
230  @go
231  (set-nargs 2)
232  (spjump .SPnvalret)
233  @no
234  (mov imm0 'nil)
235  (vpush1 imm0)
236  (vpush1 imm0)
237  (b @go))
238
239
240
241
242(defarmlapfunction %%frame-savevsp ((p arg_z))
243  (check-nargs 1)
244  (ldr arg_z (:@ arg_z (:$ arm::lisp-frame.savevsp)))
245  (bx lr))
246
247
248
249
250
251
252
253(defarmlapfunction %uvector-data-fixnum ((uv arg_z))
254  (check-nargs 1)
255  (trap-unless-fulltag= arg_z arm::fulltag-misc)
256  (add arg_z arg_z (:$ arm::misc-data-offset))
257  (bx lr))
258
259(defarmlapfunction %catch-top ((tcr arg_z))
260  (check-nargs 1)
261  (ldr arg_z (:@ tcr (:$ arm::tcr.catch-top)))
262  (cmp arg_z (:$ 0))
263  (moveq arg_z 'nil)
264  (bx lr))
265
266
267
268
269
270;;; Same as %address-of, but doesn't cons any bignums
271;;; It also left shift fixnums just like everything else.
272(defarmlapfunction %fixnum-address-of ((x arg_z))
273  (check-nargs 1)
274  (box-fixnum arg_z x)
275  (bx lr))
276
277(defarmlapfunction %dnode-address-of ((x arg_z))
278  (check-nargs 1)
279  (bic arg_z x (:$ arm::fulltagmask))
280  (bx lr))
281
282(defarmlapfunction %save-standard-binding-list ((bindings arg_z))
283  (ldr imm0 (:@ arm::rcontext (:$ arm::tcr.vs-area)))
284  (ldr imm1 (:@ imm0 (:$ arm::area.high)))
285  (push1 bindings imm1)
286  (bx lr))
287
288(defarmlapfunction %saved-bindings-address ()
289  (ldr imm0 (:@ arm::rcontext (:$ arm::tcr.vs-area)))
290  (ldr imm1 (:@ imm0 (:$ arm::area.high)))
291  (add arg_z imm1 (:$ (- arm::node-size)))
292  (bx lr))
293
294(defarmlapfunction %code-vector-pc ((code-vector arg_y) (pcptr arg_z))
295  (build-lisp-frame)
296  (macptr-ptr imm0 pcptr)
297  (ldr lr (:@ imm0 (:$ 0)))
298  (sub imm0 lr code-vector)
299  (sub imm0 imm0 (:$ arm::misc-data-offset))
300  (getvheader imm1 code-vector)
301  (header-size imm1 imm1)
302  (cmp imm0 (:lsl imm1 (:$ 2)))
303  (movhs arg_z 'nil)
304  (movlo arg_z (:lsl imm0 (:$ arm::fixnumshift)))
305  (return-lisp-frame))
306
307(defarmlapfunction %do-ff-call ((tag arg_x) (result arg_y) (entry arg_z))
308  (stmdb (:! vsp) (tag result))
309  (sploadlr .SPeabi-ff-call)
310  (blx lr)
311  (ldmia (:! vsp) (tag result))
312  (macptr-ptr imm2 result)
313  (str imm0 (:@ imm2 (:$ 0)))
314  (str imm1 (:@ imm2 (:$ 4)))
315  (vpush1 tag)
316  (mov arg_z 'nil)
317  (vpush1 arg_z)
318  (set-nargs 1)
319  (sploadlr .SPthrow)
320  (blx lr))
321 
322(defun %ff-call (entry &rest specs-and-vals)
323  (declare (dynamic-extent specs-and-vals))
324  (let* ((len (length specs-and-vals))
325         (total-words 0))
326    (declare (fixnum len total-words))
327    (let* ((result-spec (or (car (last specs-and-vals)) :void))
328           (nargs (ash (the fixnum (1- len)) -1)))
329      (declare (fixnum nargs))
330      (if (and (arm-hard-float-p)
331               (or (eq result-spec :double-float)
332                   (eq result-spec :single-float)
333                   (let* ((specs specs-and-vals))
334                     (dotimes (i nargs)
335                       (let* ((spec (car specs)))
336                         (when (or (eq spec :double-float)
337                                   (eq spec :single-float))
338                           (return t)))))))
339        (%ff-call-hard-float entry specs-and-vals)
340               
341        (ecase result-spec
342          ((:address :unsigned-doubleword :signed-doubleword
343                     :single-float :double-float
344                     :signed-fullword :unsigned-fullword
345                     :signed-halfword :unsigned-halfword
346                     :signed-byte :unsigned-byte
347                     :void)
348           (do* ((i 0 (1+ i))
349                 (specs specs-and-vals (cddr specs))
350                 (spec (car specs) (car specs)))
351                ((= i nargs))
352             (declare (fixnum i))
353             (case spec
354               ((:address :single-float
355                          :signed-fullword :unsigned-fullword
356                          :signed-halfword :unsigned-halfword
357                          :signed-byte :unsigned-byte)
358                (incf total-words))
359               ((:double-float :unsigned-doubleword :signed-doubleword)
360                #-darwin-target
361                (setq total-words (+ total-words (logand total-words 1)))
362                (incf total-words 2))
363
364               (t (if (typep spec 'unsigned-byte)
365                    (incf total-words spec)
366                    (error "unknown arg spec ~s" spec)))))
367           ;; It's necessary to ensure that the C frame is the youngest thing on
368           ;; the foreign stack here.
369           (let* ((tag (cons nil nil)))
370             (declare (dynamic-extent tag))
371             (%stack-block ((result 8))
372               (catch tag
373                 (with-macptrs ((argptr))
374                   (with-variable-c-frame
375                       total-words frame
376                       (%setf-macptr-to-object argptr frame)
377                       (let* ((arg-offset 8))
378                         (declare (fixnum arg-offset))
379                         (do* ((i 0 (1+ i))
380                               (specs specs-and-vals (cddr specs))
381                               (spec (car specs) (car specs))
382                               (val (cadr specs) (cadr specs)))
383                              ((= i nargs))
384                           (declare (fixnum i))
385                           (case spec
386                             (:address
387                              (setf (%get-ptr argptr arg-offset) val)
388                              (incf arg-offset 4))
389                             (:signed-doubleword
390                              #-darwin-target
391                              (when (logtest 7 arg-offset)
392                                (incf arg-offset 4))
393                              (setf (%%get-signed-longlong argptr arg-offset) val)
394                              (incf arg-offset 8))
395                             ((:signed-fullword :signed-halfword :signed-byte)
396                              (setf (%get-signed-long argptr arg-offset) val)
397                              (incf arg-offset 4))
398                             (:unsigned-doubleword
399                              #-darwin-target
400                              (when (logtest 7 arg-offset)
401                                (incf arg-offset 4))
402                              (setf (%%get-unsigned-longlong argptr arg-offset) val)
403                              (incf arg-offset 8))
404                             ((:unsigned-fullword :unsigned-halfword :unsigned-byte)
405                              (setf (%get-unsigned-long argptr arg-offset) val)
406                              (incf arg-offset 4))
407                             (:double-float
408                              #-darwin-target
409                              (when (logtest 7 arg-offset)
410                                (incf arg-offset 4))
411                              (setf (%get-double-float argptr arg-offset) val)
412                              (incf arg-offset 8))
413                             (:single-float
414                              (setf (%get-single-float argptr arg-offset) val)
415                              (incf arg-offset 4))
416                             (t
417                              (let* ((p 0))
418                                (declare (fixnum p))
419                                (dotimes (i (the fixnum spec))
420                                  (setf (%get-ptr argptr arg-offset) (%get-ptr val p))
421                                  (incf p 4)
422                                  (incf arg-offset 4)))))))
423                       (%do-ff-call tag result entry))))
424               (ecase result-spec
425                 (:void nil)
426                 (:address (%get-ptr result 0))
427                 (:unsigned-byte (%get-unsigned-byte result 0))
428                 (:signed-byte (%get-signed-byte result 0))
429                 (:unsigned-halfword (%get-unsigned-word result 0))
430                 (:signed-halfword (%get-signed-word result 0))
431                 (:unsigned-fullword (%get-unsigned-long result 0))
432                 (:signed-fullword (%get-signed-long result 0))
433                 (:unsigned-doubleword (%%get-unsigned-longlong result 0))
434                 (:signed-doubleword (%%get-signed-longlong result 0))
435                 (:single-float (%get-single-float result 0))
436                 (:double-float (%get-double-float result 0)))))))))))
437
438
439(defarmlapfunction %do-ff-call-hard-float ((tag arg_x) (result arg_y) (entry arg_z))
440  (stmdb (:! vsp) (tag result))
441  (sploadlr .SPeabi-ff-callhf)
442  (blx lr)
443  (ldmia (:! vsp) (tag result))
444  (macptr-ptr imm2 result)
445  (str imm0 (:@ imm2 (:$ 0)))
446  (str imm1 (:@ imm2 (:$ 4)))
447  (fstd d0 (:@ imm2 (:$ 8)))
448  (vpush1 tag)
449  (mov arg_z 'nil)
450  (vpush1 arg_z)
451  (set-nargs 1)
452  (sploadlr .SPthrow)
453  (blx lr))
454
455(defun %ff-call-hard-float (entry specs-and-vals)
456  (let* ((len (length specs-and-vals))
457         (total-words 0)
458         (fp-words 16))
459    (declare (fixnum len total-words fp-words))
460    (let* ((result-spec (or (car (last specs-and-vals)) :void))
461           (nargs (ash (the fixnum (1- len)) -1)))
462      (declare (fixnum nargs))
463      (ecase result-spec
464        ((:address :unsigned-doubleword :signed-doubleword
465                   :single-float :double-float
466                   :signed-fullword :unsigned-fullword
467                   :signed-halfword :unsigned-halfword
468                   :signed-byte :unsigned-byte
469                   :void)
470         (do* ((i 0 (1+ i))
471               (specs specs-and-vals (cddr specs))
472               (spec (car specs) (car specs)))
473              ((= i nargs))
474           (declare (fixnum i))
475           (case spec
476             ((:address :signed-fullword :unsigned-fullword
477                        :signed-halfword :unsigned-halfword
478                        :signed-byte :unsigned-byte)
479              (incf total-words))
480             (:single-float
481              (if (> fp-words 0)
482                (decf fp-words)
483                (incf total-words)))
484             (:double-float
485              (if (>= fp-words 2)
486                (if (oddp fp-words)
487                  (decf fp-words 3)
488                  (decf fp-words 2))
489                (if (oddp total-words)
490                  (incf total-words 3)
491                  (incf total-words 2))))
492             ((:unsigned-doubleword :signed-doubleword)
493              (setq total-words (+ total-words (logand total-words 1)))
494              (incf total-words 2))
495
496             (t (if (typep spec 'unsigned-byte)
497                  (incf total-words spec)
498                  (error "unknown arg spec ~s" spec)))))
499         ;; It's necessary to ensure that the C frame is the youngest thing on
500         ;; the foreign stack here.
501         (let* ((tag (cons nil nil)))
502           (declare (dynamic-extent tag))
503           (%stack-block ((result 16))
504             (catch tag
505               (with-macptrs ((argptr))
506                 (with-variable-c-frame
507                     (+ total-words 16) frame
508                     (%setf-macptr-to-object argptr frame)
509                     (let* ((fp-arg-offset 8)
510                            (arg-offset 72))
511                       (declare (fixnum arg-offset fp-arg-offset))
512                       (do* ((i 0 (1+ i))
513                             (specs specs-and-vals (cddr specs))
514                             (spec (car specs) (car specs))
515                             (val (cadr specs) (cadr specs)))
516                            ((= i nargs))
517                         (declare (fixnum i))
518                         (case spec
519                           (:address
520                            (setf (%get-ptr argptr arg-offset) val)
521                            (incf arg-offset 4))
522                           (:signed-doubleword
523                            (when (logtest 7 arg-offset)
524                              (incf arg-offset 4))
525                            (setf (%%get-signed-longlong argptr arg-offset) val)
526                            (incf arg-offset 8))
527                           ((:signed-fullword :signed-halfword :signed-byte)
528                            (setf (%get-signed-long argptr arg-offset) val)
529                            (incf arg-offset 4))
530                           (:unsigned-doubleword
531                             (when (logtest 7 arg-offset)
532                               (incf arg-offset 4))
533                             (setf (%%get-unsigned-longlong argptr arg-offset) val)
534                             (incf arg-offset 8))
535                           ((:unsigned-fullword :unsigned-halfword :unsigned-byte)
536                            (setf (%get-unsigned-long argptr arg-offset) val)
537                            (incf arg-offset 4))
538                           (:double-float
539                            (cond ((<= fp-arg-offset 64)
540                                   (when (logtest 7 fp-arg-offset)
541                                     (incf fp-arg-offset 4))
542                                   (setf (%get-double-float argptr fp-arg-offset) val)
543                                   (incf fp-arg-offset 8))
544                                  (t
545                                   (when (logtest 7 arg-offset)
546                                     (incf arg-offset 4))
547                                   (setf (%get-double-float argptr arg-offset) val)
548                                   (incf arg-offset 8))))
549                           (:single-float
550                            (cond ((< fp-arg-offset 72)
551                                   (setf (%get-single-float argptr fp-arg-offset) val)
552                                   (incf fp-arg-offset 4))
553                                  (t
554                                   (setf (%get-single-float argptr arg-offset) val)
555                                   (incf arg-offset 4))))
556                           (t
557                              (let* ((p 0))
558                                (declare (fixnum p))
559                                (dotimes (i (the fixnum spec))
560                                  (setf (%get-ptr argptr arg-offset) (%get-ptr val p))
561                                  (incf p 4)
562                                  (incf arg-offset 4)))))))
563                         (%do-ff-call-hard-float tag result entry))))
564             (ecase result-spec
565               (:void nil)
566               (:address (%get-ptr result 0))
567               (:unsigned-byte (%get-unsigned-byte result 0))
568               (:signed-byte (%get-signed-byte result 0))
569               (:unsigned-halfword (%get-unsigned-word result 0))
570               (:signed-halfword (%get-signed-word result 0))
571               (:unsigned-fullword (%get-unsigned-long result 0))
572               (:signed-fullword (%get-signed-long result 0))
573               (:unsigned-doubleword (%%get-unsigned-longlong result 0))
574               (:signed-doubleword (%%get-signed-longlong result 0))
575               (:single-float (%get-single-float result 8))
576               (:double-float (%get-double-float result 8))))))))))
577
578
579
580(defarmlapfunction %get-object ((macptr arg_y) (offset arg_z))
581  (check-nargs 2)
582  (trap-unless-xtype= arg_y arm::subtag-macptr)
583  (macptr-ptr imm0 arg_y)
584  (trap-unless-fixnum arg_z)
585  (unbox-fixnum imm1 arg_z)
586  (ldr arg_z (:@ imm0 imm1))
587  (bx lr))
588
589
590(defarmlapfunction %set-object ((macptr arg_x) (offset arg_y) (value arg_z))
591  (check-nargs 3)
592  (trap-unless-xtype= arg_x arm::subtag-macptr)
593  (macptr-ptr imm0 arg_x)
594  (trap-unless-fixnum arg_y)
595  (unbox-fixnum imm1 arg_y)
596  (str arg_z (:@ imm0 imm1))
597  (bx lr))
598
599
600(defarmlapfunction %apply-lexpr-with-method-context ((magic arg_x)
601                                                     (function arg_y)
602                                                     (args arg_z))
603  ;; Somebody's called (or tail-called) us.
604  ;; Put magic arg in arm::next-method-context (= arm::temp1).
605  ;; Put function in arm::nfn (= arm::temp2).
606  ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
607  ;;   but preserves arm::nfn/arm::next-method-context.
608  ;; Jump to the function in arm::nfn.
609  (mov arm::next-method-context magic)
610  (mov arm::nfn function)
611  (set-nargs 0)
612  (build-lisp-frame)
613  (sploadlr .SPspread-lexprz)
614  (blx lr)
615  (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
616  ;; Nothing's changed FN.
617  ;;(ldr fn (:@ sp (:$ arm::lisp-frame.savefn)))
618  (discard-lisp-frame)
619  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
620
621
622(defarmlapfunction %apply-with-method-context ((magic arg_x)
623                                               (function arg_y)
624                                               (args arg_z))
625  ;; Somebody's called (or tail-called) us.
626  ;; Put magic arg in arm::next-method-context (= arm::temp1).
627  ;; Put function in arm::nfn (= arm::temp2).
628  ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
629  ;;   but preserves arm::nfn/arm::next-method-context.
630  ;; Jump to the function in arm::nfn.
631  (mov arm::next-method-context magic)
632  (mov arm::nfn function)
633  (set-nargs 0)
634  (build-lisp-frame)
635  (sploadlr .SPspreadargZ)
636  (blx lr)
637  (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
638  ;; Nothing's changed FN.
639  ;; (ldr fn (:@ sp (:$ arm::lisp-frame.savefn)))
640  (discard-lisp-frame)
641  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
642
643
644
645
646(defarmlapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z))
647  ;; This assumes
648  ;; a) that "args" is a lexpr made via the .SPlexpr-entry mechanism
649  ;; b) That the LR on entry to this function points to the lexpr-cleanup
650  ;;    code that .SPlexpr-entry set up
651  ;; c) That there weren't any required args to the lexpr, e.g. that
652  ;;    (%lexpr-ref args (%lexpr-count args) 0) was the first arg to the gf.
653  ;; The lexpr-cleanup code will be EQ to either (lisp-global ret1valaddr)
654  ;; or (lisp-global lexpr-return1v).  In the former case, discard a frame
655  ;; from the cstack (multiple-value tossing).  Restore FN and LR from
656  ;; the first frame that .SPlexpr-entry pushed, restore vsp from (+
657  ;; args node-size), pop the argregs, and jump to the function.
658  (ref-global imm0 ret1valaddr)
659  (cmp lr imm0)
660  (ldr nargs (:@ args (:$ 0)))
661  (mov nfn method)
662  (addeq sp sp (:$ arm::lisp-frame.size))
663  (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
664  (ldr fn (:@ sp (:$ arm::lisp-frame.savefn)))
665  (ldr imm0 (:@ sp (:$ arm::lisp-frame.savevsp)))
666  (sub vsp imm0 nargs)
667  (add sp sp (:$ arm::lisp-frame.size))
668  (cmp nargs (:$ 0))
669  (ldreq pc (:@ nfn (:$ arm::function.entrypoint)))
670  (cmp nargs '2)
671  (vpop1 arg_z)
672  (ldrlo pc (:@ nfn (:$ arm::function.entrypoint)))
673  (vpop1 arg_y)
674  (ldreq pc (:@ nfn (:$ arm::function.entrypoint)))
675  (vpop1 arg_x)
676  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
677
678
679(defun %copy-function (proto &optional target)
680  (let* ((total-size (uvsize proto))
681         (new (or target (allocate-typed-vector :function total-size))))
682    (declare (fixnum total-size))
683    (when target
684      (unless (eql total-size (uvsize target))
685        (error "Wrong size target ~s" target)))
686    (%copy-gvector-to-gvector proto 0 new 0 total-size)
687    (%fix-fn-entrypoint new)))
688
689(defun replace-function-code (target-fn proto-fn)
690  (if (typep target-fn 'function)
691    (if (typep proto-fn 'function)
692      (progn
693        (setf (uvref target-fn 0) (%lookup-subprim-address
694                                   #.(arm::arm-subprimitive-offset '.SPfix-nfn-entrypoint))
695              (uvref target-fn 1) (uvref proto-fn 1))
696        (%fix-fn-entrypoint target-fn))
697      (report-bad-arg proto-fn 'function))
698    (report-bad-arg target-fn 'function)))
699
700(defun closure-function (fun)
701  (while (and (functionp fun)  (not (compiled-function-p fun)))
702    (setq fun (%svref fun 2))
703    (when (vectorp fun)
704      (setq fun (svref fun 0))))
705  fun)
706
707
708;;; For use by (setf (apply ...) ...)
709;;; (apply+ f butlast last) = (apply f (append butlast (list last)))
710(defarmlapfunction apply+ ()
711  (:arglist (function arg1 arg2 &rest other-args))
712  (check-nargs 3 nil)
713  (vpush1 arg_x)
714  (mov temp0 arg_z)                     ; last
715  (mov arg_z arg_y)                     ; butlast
716  (sub nargs nargs '2)                  ; remove count for butlast & last
717  (build-lisp-frame)
718  (sploadlr .SPspreadargz)
719  (blx lr)
720  (cmp nargs '3)
721  (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
722  (discard-lisp-frame)
723  (add nargs nargs '1)                  ; count for last
724  (strhs arg_x (:@! vsp (:$ -4)))
725  (mov arg_x arg_y)
726  (mov arg_y arg_z)
727  (mov arg_z temp0)
728  (ldr nfn (:@ nfn 'funcall))
729  (spjump .SPfuncall))
730
731(defarmlapfunction %lookup-subprim-address ((subp arg_z))
732  (ldr imm0 (:@ rcontext (:lsr subp (:$ arm::fixnumshift))))
733  (box-fixnum arg_z imm0)
734  (bx lr))
735
736(defarmlapfunction arm-hard-float-p ()
737  (check-nargs 0)
738  (ref-global arg_z arm::float-abi)
739  (tst arg_z arg_z)
740  (mov arg_z 'nil)
741  (addne arg_z arg_z (:$ arm::t-offset))
742  (bx lr))
743 
744;;; end of arm-def.lisp
Note: See TracBrowser for help on using the repository browser.