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

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

arm-constants.h, thread_manager.c: tcr.last_lisp_frame is just a natural.

arm-exceptions.c: maintain tcr.last_lisp_frame when entering/exiting
signal handlers. Signal thread interrupts by calling back to cmain
with signal 0.

arm-spentry.s: add an entrypoint that calls to undefined functions
wind up at. Dont' really need .SPtfuncallvsp. Check for pending
interrupts on ffcall return. Box the unboxed callback index in
.SPeabi_callback, don't unbox it even more.

arm-uuo.s: closer to lisp's idea of UUO encoding, but still not there.

xfasload.lisp: build the undefined function object differently.

arm-asm.lisp, arm-disassemble.lisp: uuo-slot-unbound encodes 3 registers

arm-lapmacros.lisp: define SET-GLOBAL; needs an extra temp reg.

arm-vinsns.lisp: scale-1bit-misc-index needs another shift. 3-operand
slot-unbound UUO. EEP-unresolved UUO operand order. No more .SPtfuncallvsp.
Make sure that nargs doesn't get clobbered in UNBIND-INTERRUPT-LEVEL-INLINE.

arm-array.lisp: in @string case of %init-misc, shift value, not tag.

arm-misc.lisp: add PENDING-USER-INTERRUPT, %%SAVE-APPLICATION.

arm-callback-support.lisp, arm-error-signal.lisp,
arm-trap-support.lisp,l1-boot-3.lisp: try to get basic stuff working
well enough to enable callbacks. Enable callbacks.

arm-backtrace.lisp: a little bit of platform-specific code and some
code from the PPC port, so that backtrace sort of works.

Status: can save an image (and it's more-or-less worth doing so.)
Crashes (somewhere in the type-system) compiling db-io.lisp, so I
don't yet know what undefined things would be warned about.

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