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

Last change on this file since 14159 was 14159, checked in by gb, 9 years ago

Unscramble variable-c-frame stuff. Use it to implement #'%FF-CALL.

File size: 18.0 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(defarmlapfunction %do-ff-call ((tag arg_x) (result arg_y) (entry arg_z))
297  (stmdb (:! vsp) (tag result))
298  (bla .SPeabi-ff-call)
299  (ldmia (:! vsp) (tag result))
300  (macptr-ptr imm2 result)
301  (str imm0 (:@ imm2 (:$ 0)))
302  (str imm1 (:@ imm2 (:$ 4)))
303  (vpush1 tag)
304  (mov arg_z 'nil)
305  (vpush1 arg_z)
306  (set-nargs 1)
307  (bla .SPthrow))
308 
309(defun %ff-call (entry &rest specs-and-vals)
310  (declare (dynamic-extent specs-and-vals))
311  (let* ((len (length specs-and-vals))
312         (total-words 0))
313    (declare (fixnum len total-words))
314    (let* ((result-spec (or (car (last specs-and-vals)) :void))
315           (nargs (ash (the fixnum (1- len)) -1)))
316      (declare (fixnum nargs))
317      (ecase result-spec
318        ((:address :unsigned-doubleword :signed-doubleword
319                   :single-float :double-float
320                   :signed-fullword :unsigned-fullword
321                   :signed-halfword :unsigned-halfword
322                   :signed-byte :unsigned-byte
323                   :void)
324         (do* ((i 0 (1+ i))
325               (specs specs-and-vals (cddr specs))
326               (spec (car specs) (car specs)))
327              ((= i nargs))
328           (declare (fixnum i))
329           (case spec
330             ((:address :single-float
331                        :signed-fullword :unsigned-fullword
332                        :signed-halfword :unsigned-halfword
333                        :signed-byte :unsigned-byte)
334              (incf total-words))
335             ((:double-float :unsigned-doubleword :signed-doubleword)
336              (setq total-words (+ total-words (logand total-words 1)))
337              (incf total-words 2))
338
339             (t (if (typep spec 'unsigned-byte)
340                  (incf total-words spec)
341                  (error "unknown arg spec ~s" spec)))))
342         ;; It's necessary to ensure that the C frame is the youngest thing on
343         ;; the foreign stack here.
344         (let* ((tag (cons nil nil)))
345           (declare (dynamic-extent tag))
346           (%stack-block ((result 8))
347             (catch tag
348               (with-macptrs ((argptr))
349                 (with-variable-c-frame
350                     total-words frame
351                     (%setf-macptr-to-object argptr frame)
352                     (let* ((arg-offset 8))
353                       (declare (fixnum arg-offset))
354                       (do* ((i 0 (1+ i))
355                             (specs specs-and-vals (cddr specs))
356                             (spec (car specs) (car specs))
357                             (val (cadr specs) (cadr specs)))
358                            ((= i nargs))
359                         (declare (fixnum i))
360                         (case spec
361                           (:address
362                            (setf (%get-ptr argptr arg-offset) val)
363                            (incf arg-offset 4))
364                           (:signed-doubleword
365                            (when (logtest 7 arg-offset)
366                              (incf arg-offset 4))
367                            (setf (%%get-signed-longlong argptr arg-offset) val)
368                            (incf arg-offset 8))
369                           ((:signed-fullword :signed-halfword :signed-byte)
370                            (setf (%get-signed-long argptr arg-offset) val)
371                            (incf arg-offset 4))
372                           (:unsigned-doubleword
373                             (when (logtest 7 arg-offset)
374                               (incf arg-offset 4))
375                             (setf (%%get-unsigned-longlong argptr arg-offset) val)
376                             (incf arg-offset 8))
377                           ((:unsigned-fullword :unsigned-halfword :unsigned-byte)
378                            (setf (%get-unsigned-long argptr arg-offset) val)
379                            (incf arg-offset 4))
380                           (:double-float
381                            (when (logtest 7 arg-offset)
382                              (incf arg-offset 4))
383                            (setf (%get-double-float argptr arg-offset) val)
384                            (incf arg-offset 8))
385                           (:single-float
386                            (setf (%get-single-float argptr arg-offset) val)
387                            (incf arg-offset 4))
388                           (t
389                              (let* ((p 0))
390                                (declare (fixnum p))
391                                (dotimes (i (the fixnum spec))
392                                  (setf (%get-ptr argptr arg-offset) (%get-ptr val p))
393                                  (incf p 4)
394                                  (incf arg-offset 4)))))))
395                         (%do-ff-call tag result entry))))
396             (ecase result-spec
397               (:void nil)
398               (:address (%get-ptr result 0))
399               (:unsigned-byte (%get-unsigned-byte result 0))
400               (:signed-byte (%get-signed-byte result 0))
401               (:unsigned-halfword (%get-unsigned-word result 0))
402               (:signed-halfword (%get-signed-word result 0))
403               (:unsigned-fullword (%get-unsigned-long result 0))
404               (:signed-fullword (%get-signed-long result 0))
405               (:unsigned-doubleword (%get-natural result 0))
406               (:signed-doubleword (%get-signed-natural result 0))
407               (:single-float (%get-single-float result 0))
408               (:double-float (%get-double-float result 0))))))))))
409
410
411
412(defarmlapfunction %get-object ((macptr arg_y) (offset arg_z))
413  (check-nargs 2)
414  (trap-unless-xtype= arg_y arm::subtag-macptr)
415  (macptr-ptr imm0 arg_y)
416  (trap-unless-fixnum arg_z)
417  (unbox-fixnum imm1 arg_z)
418  (ldr arg_z (:@ imm0 imm1))
419  (bx lr))
420
421
422(defarmlapfunction %set-object ((macptr arg_x) (offset arg_y) (value arg_z))
423  (check-nargs 3)
424  (trap-unless-xtype= arg_x arm::subtag-macptr)
425  (macptr-ptr imm0 arg_x)
426  (trap-unless-fixnum arg_y)
427  (unbox-fixnum imm1 arg_y)
428  (str arg_z (:@ imm0 imm1))
429  (bx lr))
430
431
432(defarmlapfunction %apply-lexpr-with-method-context ((magic arg_x)
433                                                     (function arg_y)
434                                                     (args arg_z))
435  ;; Somebody's called (or tail-called) us.
436  ;; Put magic arg in arm::next-method-context (= arm::temp1).
437  ;; Put function in arm::nfn (= arm::temp2).
438  ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
439  ;;   but preserves arm::nfn/arm::next-method-context.
440  ;; Jump to the function in arm::nfn.
441  (mov arm::next-method-context magic)
442  (mov arm::nfn function)
443  (set-nargs 0)
444  (build-lisp-frame)
445  (bla .SPspread-lexprz)
446  (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
447  ;; Nothing's changed FN.
448  ;;(ldr fn (:@ sp (:$ arm::lisp-frame.savefn)))
449  (discard-lisp-frame)
450  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
451
452
453(defarmlapfunction %apply-with-method-context ((magic arg_x)
454                                               (function arg_y)
455                                               (args arg_z))
456  ;; Somebody's called (or tail-called) us.
457  ;; Put magic arg in arm::next-method-context (= arm::temp1).
458  ;; Put function in arm::nfn (= arm::temp2).
459  ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
460  ;;   but preserves arm::nfn/arm::next-method-context.
461  ;; Jump to the function in arm::nfn.
462  (mov arm::next-method-context magic)
463  (mov arm::nfn function)
464  (set-nargs 0)
465  (build-lisp-frame)
466  (bla .SPspreadargZ)
467  (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
468  ;; Nothing's changed FN.
469  ;; (ldr fn (:@ sp (:$ arm::lisp-frame.savefn)))
470  (discard-lisp-frame)
471  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
472
473
474
475
476(defarmlapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z))
477  ;; This assumes
478  ;; a) that "args" is a lexpr made via the .SPlexpr-entry mechanism
479  ;; b) That the LR on entry to this function points to the lexpr-cleanup
480  ;;    code that .SPlexpr-entry set up
481  ;; c) That there weren't any required args to the lexpr, e.g. that
482  ;;    (%lexpr-ref args (%lexpr-count args) 0) was the first arg to the gf.
483  ;; The lexpr-cleanup code will be EQ to either (lisp-global ret1valaddr)
484  ;; or (lisp-global lexpr-return1v).  In the former case, discard a frame
485  ;; from the cstack (multiple-value tossing).  Restore FN and LR from
486  ;; the first frame that .SPlexpr-entry pushed, restore vsp from (+
487  ;; args node-size), pop the argregs, and jump to the function.
488  (ref-global imm0 ret1valaddr)
489  (cmp lr imm0)
490  (ldr nargs (:@ args (:$ 0)))
491  (mov nfn method)
492  (addeq sp sp (:$ arm::lisp-frame.size))
493  (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
494  (ldr fn (:@ sp (:$ arm::lisp-frame.savefn)))
495  (ldr imm0 (:@ sp (:$ arm::lisp-frame.savevsp)))
496  (sub vsp imm0 nargs)
497  (add sp sp (:$ arm::lisp-frame.size))
498  (cmp nargs (:$ 0))
499  (ldreq pc (:@ nfn (:$ arm::function.entrypoint)))
500  (cmp nargs '2)
501  (vpop1 arg_z)
502  (ldrlo pc (:@ nfn (:$ arm::function.entrypoint)))
503  (vpop1 arg_y)
504  (ldreq pc (:@ nfn (:$ arm::function.entrypoint)))
505  (vpop1 arg_x)
506  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
507
508
509(defun %copy-function (proto &optional target)
510  (let* ((total-size (uvsize proto))
511         (new (or target (allocate-typed-vector :function total-size))))
512    (declare (fixnum total-size))
513    (when target
514      (unless (eql total-size (uvsize target))
515        (error "Wrong size target ~s" target)))
516    (%copy-gvector-to-gvector proto 0 new 0 total-size)
517    (setf (%svref new 0 )arm::*function-initial-entrypoint*)
518    new))
519
520(defun replace-function-code (target-fn proto-fn)
521  (if (typep target-fn 'function)
522    (if (typep proto-fn 'function)
523      (setf (uvref target-fn 0) arm::*function-initial-entrypoint*
524            (uvref target-fn 1) (uvref proto-fn 1))
525      (report-bad-arg proto-fn 'function))
526    (report-bad-arg target-fn 'function)))
527
528(defun closure-function (fun)
529  (while (and (functionp fun)  (not (compiled-function-p fun)))
530    (setq fun (%svref fun 2))
531    (when (vectorp fun)
532      (setq fun (svref fun 0))))
533  fun)
534
535
536;;; For use by (setf (apply ...) ...)
537;;; (apply+ f butlast last) = (apply f (append butlast (list last)))
538(defarmlapfunction apply+ ()
539  (:arglist (function arg1 arg2 &rest other-args))
540  (check-nargs 3 nil)
541  (vpush1 arg_x)
542  (mov temp0 arg_z)                     ; last
543  (mov arg_z arg_y)                     ; butlast
544  (sub nargs nargs '2)                  ; remove count for butlast & last
545  (build-lisp-frame)
546  (bla .SPspreadargz)
547  (cmp nargs '3)
548  (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
549  (discard-lisp-frame)
550  (add nargs nargs '1)                  ; count for last
551  (strhs arg_x (:@! vsp (:$ -4)))
552  (mov arg_x arg_y)
553  (mov arg_y arg_z)
554  (mov arg_z temp0)
555  (ldr nfn (:@ nfn 'funcall))
556  (ba .SPfuncall))
557
558
559
560;;; end of arm-def.lisp
Note: See TracBrowser for help on using the repository browser.