source: release/1.7/source/level-0/ARM/arm-def.lisp @ 14887

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

propagate r14886 to 1.7 branch

File size: 18.3 KB
Line 
1;;; -*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19;;; Do an FF-CALL to MakeDataExecutable so that the data cache gets flushed.
20;;; If the GC moves this function while we're trying to flush the cache,
21;;; it'll flush the cache: no harm done in that case.
22
23(defun %make-code-executable (codev)
24  (with-macptrs (p)
25    (let* ((nbytes (ash (uvsize codev) arm::word-shift)))
26      (%vect-data-to-macptr codev p)
27      (ff-call (%kernel-import arm::kernel-import-MakeDataExecutable)
28               :address p
29               :unsigned-fullword nbytes
30               :void))))
31
32(defarmlapfunction %get-kernel-global-from-offset ((offset arg_z))
33  (check-nargs 1)
34  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
35  (ldr arg_z (:-@ imm0 (:asr offset (:$ arm::fixnumshift))))
36  (bx lr))
37
38
39(defarmlapfunction %set-kernel-global-from-offset ((offset arg_y) (new-value arg_z))
40  (check-nargs 2)
41  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
42  (ldr new-value (:-@ imm0 (:asr offset (:$ arm::fixnumshift))))
43  (bx lr))
44
45
46
47(defarmlapfunction %get-kernel-global-ptr-from-offset ((offset arg_y)
48                                                       (ptr arg_z))
49  (check-nargs 2)
50  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
51  (ldr imm0 (:-@ imm0 (:asr offset (:$ arm::fixnumshift))))
52  (str imm0 (:@ ptr (:$ target::macptr.address)))
53  (bx lr))
54
55
56
57
58(defarmlapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z))
59  (:arglist (fixnum &optional offset))
60  (check-nargs 1 2)
61  (cmp nargs '1)
62  (moveq fixnum offset)
63  (moveq offset (:$ 0))
64  (unbox-fixnum imm0 offset)
65  (ldr arg_z (:@ imm0 fixnum))
66  (bx lr))
67
68
69(defarmlapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z))
70  (:arglist (fixnum &optional offset))
71  (check-nargs 1 2)
72  (cmp nargs '1)
73  (moveq fixnum offset)
74  (moveq offset (:$ 0))
75  (unbox-fixnum imm0 offset)
76  (ldr imm0 (:@ imm0 fixnum))
77  (ba .SPmakeu32))
78
79
80
81(defarmlapfunction %fixnum-set ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z))
82  (:arglist (fixnum offset &optional new-value))
83  (check-nargs 2 3)
84  (cmp nargs '2)
85  (moveq fixnum offset)
86  (moveq offset (:$ 0))
87  (unbox-fixnum imm0 offset)
88  (str new-value (:@ imm0 fixnum))
89  (mov arg_z new-value)
90  (bx lr))
91
92(defarmlapfunction %fixnum-set-natural ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z))
93  (check-nargs 2 3)
94  (cmp nargs '2)
95  (moveq fixnum offset)
96  (moveq offset (:$ 0))
97  (unbox-fixnum imm0 offset)
98  (test-fixnum new-value)
99  (unbox-fixnum imm2 new-value)
100  (beq @store)
101  (extract-subtag imm1 new-value)
102  (cmp imm1 (:$ arm::subtag-bignum))
103  (beq @ok1)
104  (uuo-error-reg-not-xtype new-value (:$ arm::xtype-u32))
105  @ok1
106  (getvheader imm0 new-value)
107  (header-length temp0 imm0)
108  (cmp temp0 '2)
109  (ldr imm2 (:@ new-value (:$ arm::misc-data-offset)))
110  (ldreq imm1 (:@ new-value (:$ (+ arm::misc-data-offset))))
111  (ble @ok2)
112  (uuo-error-reg-not-xtype new-value (:$ arm::xtype-u32))
113  @ok2
114  (bne @one)
115  (cmp imm1 ($ 0))
116  (beq @store)
117  (uuo-error-reg-not-xtype new-value (:$ arm::xtype-u32))
118  @one
119  (cmp imm2 ($ 0))
120  (bge @store)
121  (uuo-error-reg-not-xtype new-value (:$ arm::xtype-u32))
122  @store
123  (str imm2 (:@ imm0 fixnum))
124  (mov arg_z new-value)
125  (bx lr))
126
127
128
129(defarmlapfunction %current-frame-ptr ()
130  (check-nargs 0)
131  (mov arg_z sp)
132  (bx lr))
133
134(defarmlapfunction %current-vsp ()
135  (check-nargs 0)
136  (mov arg_z vsp)
137  (bx lr))
138
139
140
141
142(defarmlapfunction %set-current-vsp ((new-vsp arg_z))
143  (check-nargs 1)
144  (mov vsp new-vsp)
145  (bx lr))
146
147
148
149(defarmlapfunction %%frame-backlink ((p arg_z))
150  (check-nargs 1)
151  (ldr imm0 (:@ p))
152  (cmp imm0 (:$ arm::lisp-frame-marker))
153  (addeq arg_z p (:$ arm::lisp-frame.size))
154  (bxeq lr)
155  (cmp imm0 (:$ arm::stack-alloc-marker))
156  (and imm1 imm0 (:$ arm::fulltagmask))
157  (addeq arg_z p '2)
158  (bxeq lr)
159  (cmp imm1 (:$ arm::fulltag-immheader))
160  (beq @imm)
161  (cmp imm1 (:$ arm::fulltag-nodeheader))
162  (movne arg_z (:$ 0))
163  (bxne lr)
164  (header-length imm0 imm0)
165 
166  (add imm0 imm0 (:$ (* 2 arm::node-size)))
167  (bic imm0 imm0 (:$ arm::node-size))
168  (add arg_z p imm0)
169  (bx lr)
170  @imm
171  (extract-lowbyte imm1 imm0)
172  (mov imm0 (:lsr imm0 (:$ arm::num-subtag-bits)))
173  (cmp imm1 (:$ arm::max-32-bit-ivector-subtag))
174  (bhi @8)
175  (mov imm0 (:lsl imm0 (:$ arm::word-shift)))
176  @align
177  (add imm0 imm0 (:$ (+ 4 7)))
178  (bic imm0 imm0 (:$ arm::fulltagmask))
179  (add arg_z p imm0)
180  (bx lr)
181  @8
182  (cmp imm1 (:$ arm::max-8-bit-ivector-subtag))
183  (bls @align)
184  (cmp imm1 (:$ arm::max-16-bit-ivector-subtag))
185  (movls imm0 (:lsl imm0 (:$ 1)))
186  (bls @align)
187  (cmp imm1 (:$ arm::subtag-double-float-vector))
188  (moveq imm0 (:lsl imm0 (:$ 3)))
189  (beq @align)
190  (add imm0 imm0 (:$ 7))
191  (mov imm0 (:lsr imm0 (:$ 3)))
192  (b @align))
193 
194 
195 
196
197
198
199
200
201(defarmlapfunction %%frame-savefn ((p arg_z))
202  (check-nargs 1)
203  (ldr arg_z (:@ arg_z (:$ arm::lisp-frame.savefn)))
204  (bx lr))
205
206(defarmlapfunction %cfp-lfun ((p arg_z))
207  (build-lisp-frame)
208  (ldr arg_y (:@ p (:$ arm::lisp-frame.savefn)))
209  (extract-typecode imm0 arg_y)
210  (cmp imm0 (:$ arm::subtag-function))
211  (ldr lr (:@ p (:$ arm::lisp-frame.savelr)))
212  (bne @no)
213  (ldr arg_x (:@ arg_y (:$ (+ arm::node-size arm::misc-data-offset))))
214  (sub imm1 lr arg_x)
215  (add imm1 imm1 (:$ (- arm::misc-data-offset)))
216  (getvheader imm0 arg_x)
217  (header-length imm0 imm0)
218  (cmp imm1 imm0)
219  (box-fixnum imm1 imm1)
220  (bhs @no)
221  (vpush1 arg_y)
222  (vpush1 imm1)
223  @go
224  (set-nargs 2)
225  (ba .SPnvalret)
226  @no
227  (mov imm0 'nil)
228  (vpush1 imm0)
229  (vpush1 imm0)
230  (b @go))
231
232
233
234
235(defarmlapfunction %%frame-savevsp ((p arg_z))
236  (check-nargs 1)
237  (ldr arg_z (:@ arg_z (:$ arm::lisp-frame.savevsp)))
238  (bx lr))
239
240
241
242
243
244
245
246(defarmlapfunction %uvector-data-fixnum ((uv arg_z))
247  (check-nargs 1)
248  (trap-unless-fulltag= arg_z arm::fulltag-misc)
249  (add arg_z arg_z (:$ arm::misc-data-offset))
250  (bx lr))
251
252(defarmlapfunction %catch-top ((tcr arg_z))
253  (check-nargs 1)
254  (ldr arg_z (:@ tcr (:$ arm::tcr.catch-top)))
255  (cmp arg_z (:$ 0))
256  (moveq arg_z 'nil)
257  (bx lr))
258
259
260
261
262
263;;; Same as %address-of, but doesn't cons any bignums
264;;; It also left shift fixnums just like everything else.
265(defarmlapfunction %fixnum-address-of ((x arg_z))
266  (check-nargs 1)
267  (box-fixnum arg_z x)
268  (bx lr))
269
270(defarmlapfunction %dnode-address-of ((x arg_z))
271  (check-nargs 1)
272  (bic arg_z x (:$ arm::fulltagmask))
273  (bx lr))
274
275(defarmlapfunction %save-standard-binding-list ((bindings arg_z))
276  (ldr imm0 (:@ arm::rcontext (:$ arm::tcr.vs-area)))
277  (ldr imm1 (:@ imm0 (:$ arm::area.high)))
278  (push1 bindings imm1)
279  (bx lr))
280
281(defarmlapfunction %saved-bindings-address ()
282  (ldr imm0 (:@ arm::rcontext (:$ arm::tcr.vs-area)))
283  (ldr imm1 (:@ imm0 (:$ arm::area.high)))
284  (add arg_z imm1 (:$ (- arm::node-size)))
285  (bx lr))
286
287(defarmlapfunction %code-vector-pc ((code-vector arg_y) (pcptr arg_z))
288  (build-lisp-frame)
289  (macptr-ptr imm0 pcptr)
290  (ldr lr (:@ imm0 (:$ 0)))
291  (sub imm0 lr code-vector)
292  (sub imm0 imm0 (:$ arm::misc-data-offset))
293  (getvheader imm1 code-vector)
294  (header-size imm1 imm1)
295  (mov imm1 (:lsr imm1 (:$ 2)))
296  (cmp imm0 imm1)
297  (movhs arg_z 'nil)
298  (movlo arg_z (:lsl imm0 (:$ arm::fixnumshift)))
299  (return-lisp-frame))
300
301(defarmlapfunction %do-ff-call ((tag arg_x) (result arg_y) (entry arg_z))
302  (stmdb (:! vsp) (tag result))
303  (bla .SPeabi-ff-call)
304  (ldmia (:! vsp) (tag result))
305  (macptr-ptr imm2 result)
306  (str imm0 (:@ imm2 (:$ 0)))
307  (str imm1 (:@ imm2 (:$ 4)))
308  (vpush1 tag)
309  (mov arg_z 'nil)
310  (vpush1 arg_z)
311  (set-nargs 1)
312  (bla .SPthrow))
313 
314(defun %ff-call (entry &rest specs-and-vals)
315  (declare (dynamic-extent specs-and-vals))
316  (let* ((len (length specs-and-vals))
317         (total-words 0))
318    (declare (fixnum len total-words))
319    (let* ((result-spec (or (car (last specs-and-vals)) :void))
320           (nargs (ash (the fixnum (1- len)) -1)))
321      (declare (fixnum nargs))
322      (ecase result-spec
323        ((:address :unsigned-doubleword :signed-doubleword
324                   :single-float :double-float
325                   :signed-fullword :unsigned-fullword
326                   :signed-halfword :unsigned-halfword
327                   :signed-byte :unsigned-byte
328                   :void)
329         (do* ((i 0 (1+ i))
330               (specs specs-and-vals (cddr specs))
331               (spec (car specs) (car specs)))
332              ((= i nargs))
333           (declare (fixnum i))
334           (case spec
335             ((:address :single-float
336                        :signed-fullword :unsigned-fullword
337                        :signed-halfword :unsigned-halfword
338                        :signed-byte :unsigned-byte)
339              (incf total-words))
340             ((:double-float :unsigned-doubleword :signed-doubleword)
341              #-darwin-target
342              (setq total-words (+ total-words (logand total-words 1)))
343              (incf total-words 2))
344
345             (t (if (typep spec 'unsigned-byte)
346                  (incf total-words spec)
347                  (error "unknown arg spec ~s" spec)))))
348         ;; It's necessary to ensure that the C frame is the youngest thing on
349         ;; the foreign stack here.
350         (let* ((tag (cons nil nil)))
351           (declare (dynamic-extent tag))
352           (%stack-block ((result 8))
353             (catch tag
354               (with-macptrs ((argptr))
355                 (with-variable-c-frame
356                     total-words frame
357                     (%setf-macptr-to-object argptr frame)
358                     (let* ((arg-offset 8))
359                       (declare (fixnum arg-offset))
360                       (do* ((i 0 (1+ i))
361                             (specs specs-and-vals (cddr specs))
362                             (spec (car specs) (car specs))
363                             (val (cadr specs) (cadr specs)))
364                            ((= i nargs))
365                         (declare (fixnum i))
366                         (case spec
367                           (:address
368                            (setf (%get-ptr argptr arg-offset) val)
369                            (incf arg-offset 4))
370                           (:signed-doubleword
371                            #-darwin-target
372                            (when (logtest 7 arg-offset)
373                              (incf arg-offset 4))
374                            (setf (%%get-signed-longlong argptr arg-offset) val)
375                            (incf arg-offset 8))
376                           ((:signed-fullword :signed-halfword :signed-byte)
377                            (setf (%get-signed-long argptr arg-offset) val)
378                            (incf arg-offset 4))
379                           (:unsigned-doubleword
380                            #-darwin-target
381                             (when (logtest 7 arg-offset)
382                               (incf arg-offset 4))
383                             (setf (%%get-unsigned-longlong argptr arg-offset) val)
384                             (incf arg-offset 8))
385                           ((:unsigned-fullword :unsigned-halfword :unsigned-byte)
386                            (setf (%get-unsigned-long argptr arg-offset) val)
387                            (incf arg-offset 4))
388                           (:double-float
389                            #-darwin-target
390                            (when (logtest 7 arg-offset)
391                              (incf arg-offset 4))
392                            (setf (%get-double-float argptr arg-offset) val)
393                            (incf arg-offset 8))
394                           (:single-float
395                            (setf (%get-single-float argptr arg-offset) val)
396                            (incf arg-offset 4))
397                           (t
398                              (let* ((p 0))
399                                (declare (fixnum p))
400                                (dotimes (i (the fixnum spec))
401                                  (setf (%get-ptr argptr arg-offset) (%get-ptr val p))
402                                  (incf p 4)
403                                  (incf arg-offset 4)))))))
404                         (%do-ff-call tag result entry))))
405             (ecase result-spec
406               (:void nil)
407               (:address (%get-ptr result 0))
408               (:unsigned-byte (%get-unsigned-byte result 0))
409               (:signed-byte (%get-signed-byte result 0))
410               (:unsigned-halfword (%get-unsigned-word result 0))
411               (:signed-halfword (%get-signed-word result 0))
412               (:unsigned-fullword (%get-unsigned-long result 0))
413               (:signed-fullword (%get-signed-long result 0))
414               (:unsigned-doubleword (%%get-unsigned-longlong result 0))
415               (:signed-doubleword (%%get-signed-longlong result 0))
416               (:single-float (%get-single-float result 0))
417               (:double-float (%get-double-float result 0))))))))))
418
419
420
421(defarmlapfunction %get-object ((macptr arg_y) (offset arg_z))
422  (check-nargs 2)
423  (trap-unless-xtype= arg_y arm::subtag-macptr)
424  (macptr-ptr imm0 arg_y)
425  (trap-unless-fixnum arg_z)
426  (unbox-fixnum imm1 arg_z)
427  (ldr arg_z (:@ imm0 imm1))
428  (bx lr))
429
430
431(defarmlapfunction %set-object ((macptr arg_x) (offset arg_y) (value arg_z))
432  (check-nargs 3)
433  (trap-unless-xtype= arg_x arm::subtag-macptr)
434  (macptr-ptr imm0 arg_x)
435  (trap-unless-fixnum arg_y)
436  (unbox-fixnum imm1 arg_y)
437  (str arg_z (:@ imm0 imm1))
438  (bx lr))
439
440
441(defarmlapfunction %apply-lexpr-with-method-context ((magic arg_x)
442                                                     (function arg_y)
443                                                     (args arg_z))
444  ;; Somebody's called (or tail-called) us.
445  ;; Put magic arg in arm::next-method-context (= arm::temp1).
446  ;; Put function in arm::nfn (= arm::temp2).
447  ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
448  ;;   but preserves arm::nfn/arm::next-method-context.
449  ;; Jump to the function in arm::nfn.
450  (mov arm::next-method-context magic)
451  (mov arm::nfn function)
452  (set-nargs 0)
453  (build-lisp-frame)
454  (bla .SPspread-lexprz)
455  (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
456  ;; Nothing's changed FN.
457  ;;(ldr fn (:@ sp (:$ arm::lisp-frame.savefn)))
458  (discard-lisp-frame)
459  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
460
461
462(defarmlapfunction %apply-with-method-context ((magic arg_x)
463                                               (function arg_y)
464                                               (args arg_z))
465  ;; Somebody's called (or tail-called) us.
466  ;; Put magic arg in arm::next-method-context (= arm::temp1).
467  ;; Put function in arm::nfn (= arm::temp2).
468  ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
469  ;;   but preserves arm::nfn/arm::next-method-context.
470  ;; Jump to the function in arm::nfn.
471  (mov arm::next-method-context magic)
472  (mov arm::nfn function)
473  (set-nargs 0)
474  (build-lisp-frame)
475  (bla .SPspreadargZ)
476  (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
477  ;; Nothing's changed FN.
478  ;; (ldr fn (:@ sp (:$ arm::lisp-frame.savefn)))
479  (discard-lisp-frame)
480  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
481
482
483
484
485(defarmlapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z))
486  ;; This assumes
487  ;; a) that "args" is a lexpr made via the .SPlexpr-entry mechanism
488  ;; b) That the LR on entry to this function points to the lexpr-cleanup
489  ;;    code that .SPlexpr-entry set up
490  ;; c) That there weren't any required args to the lexpr, e.g. that
491  ;;    (%lexpr-ref args (%lexpr-count args) 0) was the first arg to the gf.
492  ;; The lexpr-cleanup code will be EQ to either (lisp-global ret1valaddr)
493  ;; or (lisp-global lexpr-return1v).  In the former case, discard a frame
494  ;; from the cstack (multiple-value tossing).  Restore FN and LR from
495  ;; the first frame that .SPlexpr-entry pushed, restore vsp from (+
496  ;; args node-size), pop the argregs, and jump to the function.
497  (ref-global imm0 ret1valaddr)
498  (cmp lr imm0)
499  (ldr nargs (:@ args (:$ 0)))
500  (mov nfn method)
501  (addeq sp sp (:$ arm::lisp-frame.size))
502  (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
503  (ldr fn (:@ sp (:$ arm::lisp-frame.savefn)))
504  (ldr imm0 (:@ sp (:$ arm::lisp-frame.savevsp)))
505  (sub vsp imm0 nargs)
506  (add sp sp (:$ arm::lisp-frame.size))
507  (cmp nargs (:$ 0))
508  (ldreq pc (:@ nfn (:$ arm::function.entrypoint)))
509  (cmp nargs '2)
510  (vpop1 arg_z)
511  (ldrlo pc (:@ nfn (:$ arm::function.entrypoint)))
512  (vpop1 arg_y)
513  (ldreq pc (:@ nfn (:$ arm::function.entrypoint)))
514  (vpop1 arg_x)
515  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
516
517
518(defun %copy-function (proto &optional target)
519  (let* ((total-size (uvsize proto))
520         (new (or target (allocate-typed-vector :function total-size))))
521    (declare (fixnum total-size))
522    (when target
523      (unless (eql total-size (uvsize target))
524        (error "Wrong size target ~s" target)))
525    (%copy-gvector-to-gvector proto 0 new 0 total-size)
526    (setf (%svref new 0) #.(ash (arm::arm-subprimitive-address '.SPfix-nfn-entrypoint) (- arm::fixnumshift)))
527    new))
528
529(defun replace-function-code (target-fn proto-fn)
530  (if (typep target-fn 'function)
531    (if (typep proto-fn 'function)
532      (setf (uvref target-fn 0) #.(ash (arm::arm-subprimitive-address '.SPfix-nfn-entrypoint) (- arm::fixnumshift))
533            (uvref target-fn 1) (uvref proto-fn 1))
534      (report-bad-arg proto-fn 'function))
535    (report-bad-arg target-fn 'function)))
536
537(defun closure-function (fun)
538  (while (and (functionp fun)  (not (compiled-function-p fun)))
539    (setq fun (%svref fun 2))
540    (when (vectorp fun)
541      (setq fun (svref fun 0))))
542  fun)
543
544
545;;; For use by (setf (apply ...) ...)
546;;; (apply+ f butlast last) = (apply f (append butlast (list last)))
547(defarmlapfunction apply+ ()
548  (:arglist (function arg1 arg2 &rest other-args))
549  (check-nargs 3 nil)
550  (vpush1 arg_x)
551  (mov temp0 arg_z)                     ; last
552  (mov arg_z arg_y)                     ; butlast
553  (sub nargs nargs '2)                  ; remove count for butlast & last
554  (build-lisp-frame)
555  (bla .SPspreadargz)
556  (cmp nargs '3)
557  (ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
558  (discard-lisp-frame)
559  (add nargs nargs '1)                  ; count for last
560  (strhs arg_x (:@! vsp (:$ -4)))
561  (mov arg_x arg_y)
562  (mov arg_y arg_z)
563  (mov arg_z temp0)
564  (ldr nfn (:@ nfn 'funcall))
565  (ba .SPfuncall))
566
567
568
569;;; end of arm-def.lisp
Note: See TracBrowser for help on using the repository browser.