source: branches/arm/compiler/ARM/arm-lapmacros.lisp @ 13859

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

NTH-IMMEDIATE: add 1 to skip function entrypoint.
Define an NTH-IMMEDIATE lapmacro.

File size: 9.5 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2010 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
18(eval-when (:compile-toplevel :load-toplevel :execute)
19  (require "ARM-LAP"))
20
21
22
23
24(defarmlapmacro set-nargs (n)
25  (check-type n (unsigned-byte 8))
26  `(mov nargs ($ (ash ,n arm::fixnumshift))))
27
28(defarmlapmacro check-nargs (min &optional (max min))
29  (if (eq max min)
30    `(progn
31      (cmp nargs (:$ (ash ,min arm::fixnumshift)))
32      (uuo-error-wrong-nargs (:? ne)))
33    (if (null max)
34      (unless (= min 0)
35        `(progn
36          (cmp nargs (:$ (ash ,min arm::fixnumshift)))
37          (uuo-error-wrong-nargs (:? lo))))
38      (if (= min 0)
39        `(progn
40          (cmp nargs ($ (ash ,max arm::fixnumshift)))
41          (uuo-error-wrong-nargs (:? hi)))
42        `(progn
43          (cmp nargs ($ (ash ,max arm::fixnumshift)))
44          (uuo-error-wrong-nargs (:? lo))
45          (cmp nargs ($ (ash ,max arm::fixnumshift)))
46          (uuo-error-wrong-nargs (:? hi)))))))
47
48
49
50
51
52;;; This needs to be done if we aren't a leaf function (e.g., if we
53;;; clobber our return address or need to reference any constants.  Note
54;;; that it's not atomic wrt a preemptive scheduler, but we need to
55;;; pretend that it will be.)  The VSP to be saved is the value of the
56;;; VSP before any of this function's arguments were vpushed by its
57;;; caller; that's not the same as the VSP register if any non-register
58;;; arguments were received, but is usually easy to compute.
59
60(defarmlapmacro build-lisp-frame (&optional (marker-reg 'imm0) (vsp 'vsp))
61  `(progn
62    (mov ,marker-reg ($ arm::lisp-frame-marker))
63    (stmdb (:! sp) (,marker-reg ,vsp fn lr))))
64
65(defarmlapmacro restore-lisp-frame (&optional (marker-reg 'imm0) (vsp 'vsp))
66  `(ldmia (:! sp) (,marker-reg ,vsp fn lr)))
67
68(defarmlapmacro return-lisp-frame (&optional (marker-reg 'imm0))
69  `(ldmia (:! sp) (,marker-reg vsp fn pc)))
70
71
72(defarmlapmacro push1 (src stack)
73  `(str ,src (:+@! ,stack (:$ (- arm::node-size)))))
74
75(defarmlapmacro vpush1 (src)
76  `(push1 ,src vsp))
77
78
79(defarmlapmacro pop1 (dest stack)
80  `(ldr ,dest (:@+ ,stack (:$ arm::node-size))))
81
82(defarmlapmacro vpop1 (dest)
83  `(pop1 ,dest vsp))
84
85(defarmlapmacro %cdr (dest node)
86  `(ldr ,dest (:@ ,node (:$ arm::cons.cdr))))
87
88(defarmlapmacro %car (dest node)
89  `(ldr ,dest (:@ ,node (:$ arm::cons.car))))
90
91
92
93(defarmlapmacro extract-lisptag (dest node)
94  `(and ,dest ,node (:$ arm::tagmask)))
95
96(defarmlapmacro extract-fulltag (dest node)
97  `(and ,dest ,node (:$ arm::fulltagmask)))
98
99
100(defarmlapmacro extract-subtag (dest node)
101  `(ldrb ,dest (:@ ,node (:$ arm::misc-subtag-offset))))
102
103(defarmlapmacro extract-typecode (dest node)
104  `(progn
105    (and ,dest ,node (:$ arm::tagmask))
106    (cmp ,dest (:$ arm::tag-misc))
107    (ldrbeq ,dest (:@ ,node (:$ arm::misc-subtag-offset)))))
108
109;;; Set the EQ bit if NODE is a fixnum
110(defarmlapmacro test-fixnum (node)
111  `(tst ,node (:$ arm::tagmask)))
112
113(defarmlapmacro trap-unless-fixnum (node)
114  `(progn
115    (test-fixnum ,node)
116    (uuo-error-reg-not-lisptag (:? ne) ,node (:$ arm::tag-fixnum))))
117
118
119(defarmlapmacro trap-unless-lisptag= (node tag &optional (immreg 'imm0))
120  `(progn
121    (extract-lisptag ,immreg ,node)
122    (cmp ,immreg (:$ ,tag))
123    (uuo-error-reg-not-lisptag (:? ne) ,node (:$ ,tag))))
124
125(defarmlapmacro trap-unless-fulltag= (node tag &optional (immreg 'imm0))
126  `(progn
127    (extract-fulltag ,immreg ,node)
128    (cmp ,immreg (:$ ,tag))
129    (uuo-error-reg-not-fulltag (:? ne) ,node (:$ ,tag))))
130
131
132(defarmlapmacro trap-unless-xtype= (node tag &optional (immreg 'imm0))
133  `(progn
134    (extract-typecode ,immreg ,node)
135    (cmp ,immreg (:$ ,tag))
136    (uuo-error-reg-not-xtype (:? ne) ,node (:$ ,tag))))
137
138
139(defarmlapmacro load-constant (dest constant)
140  `(ldr ,dest (:@ fn ',constant)))
141
142;;; This is about as hard on the pipeline as anything I can think of.
143(defarmlapmacro call-symbol (function-name)
144  `(progn
145    (load-constant fname ,function-name)
146    (ldr nfn (:@ fname (:$ arm::symbol.fcell)))
147    (ldr lr (:@ nfn (:$ arm::function.entrypoint)))
148    (blx lr)))
149
150(defarmlapmacro sp-call-symbol (function-name)
151  `(progn
152     (load-constant fname ,function-name)
153     (bla .SPjmpsym)))
154
155(defarmlapmacro getvheader (dest src)
156  `(ldr ,dest (:@ ,src (:$ arm::misc-header-offset))))
157
158;;; "Size" is unboxed element-count.
159(defarmlapmacro header-size (dest vheader)
160  `(mov ,dest (:lsr ,vheader (:$ arm::num-subtag-bits))))
161
162
163;;; "Length" is fixnum element-count.
164(defarmlapmacro header-length (dest vheader)
165  `(progn
166    (bic ,dest ,vheader (:$ arm::subtag-mask))
167    (mov ,dest (:lsr ,dest (:$ (- arm::num-subtag-bits arm::fixnumshift))))))
168
169
170(defarmlapmacro header-subtag[fixnum] (dest vheader)
171  `(progn
172    (mov ,dest (:$ (ash arm::subtag-mask arm::fixnumshift)))
173    (and ,dest ,dest (:lsl ,vheader (:$ arm::fixnumshift)))))
174
175
176(defarmlapmacro vector-size (dest v vheader)
177  `(progn
178     (getvheader ,vheader ,v)
179     (header-size ,dest ,vheader)))
180
181(defarmlapmacro vector-length (dest v vheader)
182  `(progn
183     (getvheader ,vheader ,v)
184     (header-length ,dest ,vheader)))
185
186
187;;; Reference a 32-bit miscobj entry at a variable index.
188;;; Make the caller explicitly designate a scratch register
189;;; to use for the scaled index.
190
191(defarmlapmacro vref32 (dest miscobj index scaled-idx)
192  `(progn
193    (add ,scaled-idx ,index (:$ arm::misc-data-offset))
194    (ldr ,dest (:@ ,miscobj ,scaled-idx))))
195
196;; The simple (no-memoization) case.
197(defarmlapmacro vset32 (src miscobj index scaled-idx)
198  `(progn
199    (add ,scaled-idx ,index (:$ arm::misc-data-offset))
200    (str ,src (:@ ,miscobj ,scaled-idx))))
201
202(defarmlapmacro extract-lowbyte (dest src)
203  `(and ,dest ,src (:$ arm::subtag-mask)))
204
205(defarmlapmacro unbox-fixnum (dest src)
206  `(mov ,dest (:asr ,src (:$ arm::fixnumshift))))
207
208(defarmlapmacro box-fixnum (dest src)
209  `(mov ,dest (:lsl ,src (:$ arm::fixnumshift))))
210
211
212
213;;; If check is non-nil, type checks src
214(defarmlapmacro unbox-base-char (dest src &optional check)
215  `(progn
216    ,@(if check
217          `((trap-unless-xtype= ,src arm::subtag-character ,dest)))
218    (mov ,dest ,src (:lsr (:$ arm::charcode-shift)))))
219
220
221
222
223(defarmlapmacro ref-global (reg sym)
224  (let* ((offset (arm::%kernel-global sym)))
225    `(progn
226      (mov ,reg (:$ (- arm::nil-value arm::fulltag-nil)))
227      (ldr ,reg (:@ ,reg (:$ ,offset))))))
228
229
230
231
232
233
234
235
236
237(defarmlapmacro cond->boolean (cc dest rx ry)
238  `(progn
239    (cmp ,rx ,ry)
240    (mov ,dest 'nil)
241    (add (:? ,cc) ,dest ,dest (:$ arm::t-offset))))
242
243
244(defarmlapmacro repeat (n inst)
245  (let* ((insts ()))
246    (dotimes (i n `(progn ,@(nreverse insts)))
247      (push inst insts))))
248
249(defarmlapmacro get-single-float (dest node temp)
250  `(progn
251    (ldr ,temp (:@ ,node (:$ arm::single-float.value)))
252    (fmsr ,dest ,temp)))
253
254(defarmlapmacro get-double-float (dest node)
255  `(progn
256    (ldrd imm0 (:@ ,node (:$ arm::double-float.value)))
257    (fmdrr ,dest imm0 imm1)))
258 
259
260(defarmlapmacro put-single-float (src node temp)
261  `(progn
262    (fmrs ,temp ,src)
263    (str ,temp (:@ ,node (:$ arm::single-float.value)))))
264
265(defarmlapmacro put-double-float (src node)
266  `(progn
267    (fmrrd imm0 imm1 ,src)
268    (strd imm0 (:@ ,node (:$ arm::double-float.value)))))
269
270
271(defarmlapmacro clear-fpu-exceptions ()
272  (error "Later."))
273
274
275
276(defarmlapmacro digit-h (dest src)
277  `(progn
278    (mov ,dest (:$ (ash #xff arm::fixnumshift)))
279    (orr ,dest ,dest (:lsl ,dest (:$ 8)))
280    (and ,dest ,dest (:lsr ,src  (:$ (- 16 arm::fixnumshift))))))
281
282(defarmlapmacro digit-l (dest src)
283  `(progn
284    (mov ,dest (:$ (ash #xff arm::fixnumshift)))
285    (orr ,dest ,dest (:lsl ,dest (:$ 8)))
286    (and ,dest ,dest (:lsl ,src  (:$ arm::fixnumshift)))))
287 
288
289(defarmlapmacro compose-digit (dest high low)
290  ;; Can we assume that HIGH and LOW are boxed 16-bit fixnums ?
291  ;; This code does ...
292  `(progn
293    (mov ,dest (:lsl ,high (:$ (- 16 arm::fixnumshift))))
294    (orr ,dest ,dest (:lsr ,low (:$ arm::fixnumshift)))))
295
296(defarmlapmacro macptr-ptr (dest macptr)
297  `(ldr ,dest (:@ ,macptr (:$ arm::macptr.address))))
298
299(defarmlapmacro svref (dest index vector)
300 `(ldr ,dest (:@ ,vector (:$ (+ (* 4 ,index) arm::misc-data-offset)))))
301
302;;; Immediate indices (for e.g. gfs) don't account for the entrypoint.
303(defarmlapmacro nth-immediate (dest index vector)
304  `(svref ,dest (1+ ,index) ,vector))
305
306;;; This evals its args in the wrong order.
307;;; Can't imagine any code will care.
308(defarmlapmacro svset (new-value index vector)
309  `(str ,new-value (:@ ,vector (:$ (+ (* 4 ,index) arm::misc-data-offset)))))
310
311(defarmlapmacro vpush-argregs ()
312  (let* ((none (gensym)))
313  `(progn
314    (cmp nargs (:$ 0))
315    (beq ,none)
316    (cmp nargs '2)
317    (strgt arg_x (:@! vsp (:$ (- arm::node-size))))
318    (strge arg_y (:@! vsp (:$ (- arm::node-size))))
319    (str arg_z (:@! vsp (:$ (- arm::node-size))))
320     ,none)))
321
322
323
324
325
326;;; Set the most significant bit in DEST, clear all other bits.
327(defarmlapmacro load-highbit (dest)
328  `(mov ,dest (:$ #x80000000)))
329
330                                           
331(defarmlapmacro u32-ref (dest index vector)
332  `(ldr ,dest (:@ ,vector (:$ (+ (* 4 ,index) arm::misc-data-offset)))))
333
334(defarmlapmacro u32-set (new-value index vector)
335  `(str ,new-value (:@ ,vector (:$ (+ (* 4 ,index) arm::misc-data-offset)))))
336
337(provide "ARM-LAPMACROS")
338
339;;; end of arm-lapmacros.lisp
Note: See TracBrowser for help on using the repository browser.