Context Navigation

source: branches/arm/compiler/ARM/arm-vinsns.lisp @ 13794

Visit:

Last change on this file since 13794 was 13794, checked in by gb, 11 years ago
Need SINGLE-FLOAT-COMPARE vinsn. VPUSH-ARGREGS: need to use predecrement (stmdb, not stm) when vpushing multiple registers. LRI: try to load u16 constants by mov/orr, not by pc-relative ldr. TEMP-PUSH-UNBOXED-WORD: need to use :@!.
File size: 124.0 KB

Line
1	;;;-- Mode: Lisp; Package: CCL --
2	;;;
3	;;; Copyright (C) 2010 Clozure Associates
4	;;; Copyright (C) 1994-2001 Digitool, Inc
5	;;; This file is part of Clozure CL.
6	;;;
7	;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8	;;; License , known as the LLGPL and distributed with Clozure CL as the
9	;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL,
10	;;; which is distributed with Clozure CL as the file "LGPL". Where these
11	;;; conflict, the preamble takes precedence.
12	;;;
13	;;; Clozure CL is referenced in the preamble as the "LIBRARY."
14	;;;
15	;;; The LLGPL is also available online at
16	;;; http://opensource.franz.com/preamble.html
17
18
19	(in-package "CCL")
20
21	(eval-when (:compile-toplevel :load-toplevel :execute)
22	(require "VINSN")
23	(require "ARM-BACKEND"))
24
25	(eval-when (:compile-toplevel :execute)
26	(require "ARMENV"))
27
28	(defmacro define-arm-vinsn (vinsn-name (results args &optional temps) &body body)
29	(%define-vinsn arm-backend vinsn-name results args temps body))
30
31
32	;;; Index "scaling" and constant-offset misc-ref vinsns.
33
34	(define-arm-vinsn scale-node-misc-index (((dest :u32))
35	((idx :imm) ; A fixnum
36	)
37	())
38	(add dest idx (:$ arm::misc-data-offset)))
39
40	(define-arm-vinsn scale-32bit-misc-index (((dest :u32))
41	((idx :imm) ; A fixnum
42	)
43	())
44	(add dest idx (:$ arm::misc-data-offset)))
45
46	(define-arm-vinsn scale-16bit-misc-index (((dest :u32))
47	((idx :imm) ; A fixnum
48	)
49	())
50	(mov dest (:lsr idx (:$ 1)))
51	(add dest dest (:$ arm::misc-data-offset)))
52
53	(define-arm-vinsn scale-8bit-misc-index (((dest :u32))
54	((idx :imm) ; A fixnum
55	)
56	())
57	(mov dest (:lsr idx (:$ 2)))
58	(add dest dest (:$ arm::misc-data-offset)))
59
60	(define-arm-vinsn scale-64bit-misc-index (((dest :u32))
61	((idx :imm) ; A fixnum
62	)
63	())
64	(add dest idx idx)
65	(add dest dest (:$ arm::misc-dfloat-offset)))
66
67
68	(define-arm-vinsn scale-1bit-misc-index (((word-index :u32)
69	(bitnum :u8)) ; (unsigned-byte 5)
70	((idx :imm) ; A fixnum
71	)
72	)
73	(mov word-index (:lsr idx (:$ arm::fixnumshift)))
74	(and bitnum word-index (:$ 31))
75	(mov word-index (:lsr word-index (:$ 5)))
76	(add word-index word-index (:$ arm::misc-data-offset)))
77
78
79
80	(define-arm-vinsn misc-ref-u32 (((dest :u32))
81	((v :lisp)
82	(scaled-idx :u32))
83	())
84	(ldr dest (:+@ v scaled-idx)))
85
86
87	(define-arm-vinsn misc-ref-c-u32 (((dest :u32))
88	((v :lisp)
89	(idx :u32const))
90	())
91	(ldr dest (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))))
92
93	(define-arm-vinsn misc-ref-s32 (((dest :s32))
94	((v :lisp)
95	(scaled-idx :u32))
96	())
97	(ldr dest (:+@ v scaled-idx)))
98
99	(define-arm-vinsn misc-ref-c-s32 (((dest :s32))
100	((v :lisp)
101	(idx :u32const))
102	())
103	(ldr dest (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))))
104
105
106	(define-arm-vinsn misc-set-c-u32 (()
107	((val :u32)
108	(v :lisp)
109	(idx :u32const)))
110	(str val (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))))
111
112	(define-arm-vinsn misc-set-c-s32 (()
113	((val :s32)
114	(v :lisp)
115	(idx :u32const)))
116	(str val (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))))
117
118	(define-arm-vinsn misc-set-u32 (()
119	((val :u32)
120	(v :lisp)
121	(scaled-idx :u32)))
122	(str val (:+@ v scaled-idx)))
123
124	(define-arm-vinsn misc-set-s32 (()
125	((val :s32)
126	(v :lisp)
127	(scaled-idx :u32)))
128	(str val (:+@ v scaled-idx)))
129
130
131	(define-arm-vinsn misc-ref-single-float (((dest :single-float))
132	((v :lisp)
133	(scaled-idx :u32))
134	((temp :u32)))
135	(ldr temp (:@ v scaled-idx))
136	(fmsr dest temp))
137
138	(define-arm-vinsn misc-ref-c-single-float (((dest :single-float))
139	((v :lisp)
140	(idx :u32const))
141	((temp :u32)))
142	(ldr temp (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2)))))
143	(fmsr dest temp))
144
145	(define-arm-vinsn misc-ref-double-float (((dest :double-float))
146	((v :lisp)
147	(scaled-idx :u32))
148	((low (:u32 #.arm::imm0))
149	(high (:u32 #.arm::imm1))))
150	(ldrd low (:@ v scaled-idx))
151	(fmdrr dest low high))
152
153
154	(define-arm-vinsn misc-ref-c-double-float (((dest :double-float))
155	((v :lisp)
156	(idx :u32const))
157	((low (:u32 #.arm::imm0))
158	(high (:u32 #.arm::imm1))))
159	(ldrd low (:@ v (:$ idx)))
160	(fmdrr dest low high))
161
162	(define-arm-vinsn misc-set-c-double-float (((val :double-float))
163	((v :lisp)
164	(idx :u32const))
165	((low (:u32 #.arm::imm0))
166	(high (:u32 #.arm::imm1))))
167	(fmrrd low high val)
168	(strd low (:@ v (:$ (:apply + arm::misc-dfloat-offset (:apply ash idx 3))))))
169
170	(define-arm-vinsn misc-set-double-float (()
171	((val :double-float)
172	(v :lisp)
173	(scaled-idx :u32))
174	((low (:u32 #.arm::imm0))
175	(high (:u32 #.arm::imm1))))
176	(fmrrd low high val)
177	(strd low (:@ v scaled-idx)))
178
179	(define-arm-vinsn misc-set-c-single-float (()
180	((val :single-float)
181	(v :lisp)
182	(idx :u32const))
183	((temp :u32)))
184	(fmrs temp val)
185	(str temp (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))))
186
187
188
189	(define-arm-vinsn misc-set-single-float (()
190	((val :single-float)
191	(v :lisp)
192	(scaled-idx :u32))
193	((temp :u32)))
194	(fmrs temp val)
195	(str temp (:@ v scaled-idx)))
196
197
198	(define-arm-vinsn misc-ref-u16 (((dest :u16))
199	((v :lisp)
200	(scaled-idx :u32))
201	())
202	(ldrh dest (:+@ v scaled-idx)))
203
204	(define-arm-vinsn misc-ref-c-u16 (((dest :u16))
205	((v :lisp)
206	(idx :u32const))
207	())
208	(ldrh dest (:+@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1))))))
209
210	(define-arm-vinsn misc-set-c-u16 (((val :u16))
211	((v :lisp)
212	(idx :u32const))
213	())
214	(strh val (:+@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1))))))
215
216	(define-arm-vinsn misc-set-u16 (((val :u16))
217	((v :lisp)
218	(scaled-idx :s32)))
219	(strh val (:+@ v scaled-idx)))
220
221	(define-arm-vinsn misc-ref-s16 (((dest :s16))
222	((v :lisp)
223	(scaled-idx :u32))
224	())
225	(ldrsh dest (:@ v scaled-idx)))
226
227	(define-arm-vinsn misc-ref-c-s16 (((dest :s16))
228	((v :lisp)
229	(idx :u32const))
230	())
231	(ldrsh dest (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1))))))
232
233
234	(define-arm-vinsn misc-set-c-s16 (((val :s16))
235	((v :lisp)
236	(idx :u32const))
237	())
238	(strh val (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 1))))))
239
240	(define-arm-vinsn misc-set-s16 (((val :s16))
241	((v :lisp)
242	(scaled-idx :s32)))
243	(strh val (:@ v scaled-idx)))
244
245	(define-arm-vinsn misc-ref-u8 (((dest :u8))
246	((v :lisp)
247	(scaled-idx :u32))
248	())
249	(ldrb dest (:@ v scaled-idx)))
250
251	(define-arm-vinsn misc-ref-c-u8 (((dest :u8))
252	((v :lisp)
253	(idx :u32const))
254	())
255	(ldrb dest (:@ v (:$ (:apply + arm::misc-data-offset idx)))))
256
257	(define-arm-vinsn misc-set-c-u8 (((val :u8))
258	((v :lisp)
259	(idx :u32const))
260	())
261	(strb val (:@ v (:$ (:apply + arm::misc-data-offset idx)))))
262
263	(define-arm-vinsn misc-set-u8 (((val :u8))
264	((v :lisp)
265	(scaled-idx :u32))
266	())
267	(strb val (:@ v scaled-idx)))
268
269	(define-arm-vinsn misc-ref-s8 (((dest :s8))
270	((v :lisp)
271	(scaled-idx :u32))
272	())
273	(ldrsb dest (:@ v scaled-idx)))
274
275	(define-arm-vinsn misc-ref-c-s8 (((dest :s8))
276	((v :lisp)
277	(idx :u32const))
278	())
279	(ldrsb dest (:@ v (:$ (:apply + arm::misc-data-offset idx)))))
280
281	(define-arm-vinsn misc-set-c-s8 (((val :s8))
282	((v :lisp)
283	(idx :u32const))
284	())
285	(strb val (:@ v (:$ (:apply + arm::misc-data-offset idx)))))
286
287	(define-arm-vinsn misc-set-s8 (((val :s8))
288	((v :lisp)
289	(scaled-idx :u32))
290	())
291	(strb val (:@ v scaled-idx)))
292
293	#+notyet
294	(define-arm-vinsn misc-ref-c-bit (((dest :u8))
295	((v :lisp)
296	(idx :u32const))
297	())
298	(lwz dest (:apply + arm::misc-data-offset (:apply ash idx -5)) v)
299	(rlwinm dest dest (:apply 1+ (:apply logand idx #x1f)) 31 31))
300
301	#+notyet
302	(define-arm-vinsn misc-ref-c-bit-fixnum (((dest :imm))
303	((v :lisp)
304	(idx :u32const))
305	((temp :u32)))
306	(lwz temp (:apply + arm::misc-data-offset (:apply ash idx -5)) v)
307	(rlwinm dest
308	temp
309	(:apply + 1 arm::fixnumshift (:apply logand idx #x1f))
310	(- arm::least-significant-bit arm::fixnumshift)
311	(- arm::least-significant-bit arm::fixnumshift)))
312
313
314	(define-arm-vinsn misc-ref-node (((dest :lisp))
315	((v :lisp)
316	(scaled-idx :s32))
317	())
318	(ldr dest (:@ v scaled-idx)))
319
320
321
322
323	(define-arm-vinsn misc-ref-c-node (((dest :lisp))
324	((v :lisp)
325	(idx :s16const))
326	())
327	(ldr dest (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))))
328
329	(define-arm-vinsn misc-set-node (()
330	((val :lisp)
331	(v :lisp)
332	(scaled-idx :u32)))
333	(str val (:@ v scaled-idx)))
334
335	;;; This should only be used for initialization (when the value being
336	;;; stored is known to be older than the vector V.)
337	(define-arm-vinsn misc-set-c-node (()
338	((val :lisp)
339	(v :lisp)
340	(idx :s16const))
341	())
342	(str val (:@ v (:$ (:apply + arm::misc-data-offset (:apply ash idx 2))))))
343
344
345	(define-arm-vinsn misc-element-count-fixnum (((dest :imm))
346	((v :lisp))
347	((temp :u32)))
348	(ldr temp (:@ v (:$ arm::misc-header-offset)))
349	(bic temp temp (:$ arm::subtag-mask))
350	(mov dest (:lsr temp (:$ (- arm::num-subtag-bits arm::fixnum-shift)))))
351
352	(define-arm-vinsn check-misc-bound (()
353	((idx :imm)
354	(v :lisp))
355	((temp :u32)))
356	(ldr temp (:@ v (:$ arm::misc-header-offset)))
357	(bic temp temp (:$ arm::subtag-mask))
358	(cmp idx (:lsr temp (:$ (- arm::num-subtag-bits arm::fixnum-shift))))
359	(uuo-error-vector-bounds (:? hs) idx v))
360
361	(define-arm-vinsn 2d-unscaled-index (((dest :imm)
362	(dim1 :u32))
363	((dim1 :u32)
364	(i :imm)
365	(j :imm)))
366	(mul dim1 i dim1)
367	(add dest dim1 j))
368
369	;; dest <- (+ (* i dim1 dim2) (* j dim2) k)
370
371	(define-arm-vinsn 3d-unscaled-index (((dest :imm)
372	(dim1 :u32)
373	(dim2 :u32))
374	((dim1 :u32)
375	(dim2 :u32)
376	(i :imm)
377	(j :imm)
378	(k :imm)))
379	(mul dim1 dim1 dim2)
380	(mul dim2 j dim2)
381	(mul dim1 i dim1)
382	(add dim2 dim1 dim2)
383	(add dest dim2 k))
384
385
386	(define-arm-vinsn 2d-dim1 (((dest :u32))
387	((header :lisp)))
388	(ldr dest (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))))))
389	(mov dest (:asr dest (:$ arm::fixnumshift))))
390
391
392
393	(define-arm-vinsn 3d-dims (((dim1 :u32)
394	(dim2 :u32))
395	((header :lisp)))
396	(ldr dim1 (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))))))
397	(ldr dim2 (:@ header (:$ (+ arm::misc-data-offset (* 4 (+ 2 arm::arrayH.dim0-cell))))))
398	(mov dim1 (:asr dim1 (:$ arm::fixnumshift)))
399	(mov dim2 (:asr dim2 (:$ arm::fixnumshift))))
400
401	;; Return dim1 (unboxed)
402	(define-arm-vinsn check-2d-bound (((dim :u32))
403	((i :imm)
404	(j :imm)
405	(header :lisp)))
406	(ldr dim (:@ header (:$ (+ arm::misc-data-offset (* 4 arm::arrayH.dim0-cell)))))
407	(cmp i dim)
408	(uuo-error-array-bounds (:? hs) i header)
409	(ldr dim (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))))))
410	(cmp j dim)
411	(uuo-error-array-bounds (:? hs) j header)
412	(mov dim (:asr dim (:$ arm::fixnumshift))))
413
414	(define-arm-vinsn check-3d-bound (((dim1 :u32)
415	(dim2 :u32))
416	((i :imm)
417	(j :imm)
418	(k :imm)
419	(header :lisp)))
420	(ldr dim1 (:@ header (:$ (+ arm::misc-data-offset (* 4 arm::arrayH.dim0-cell)))))
421	(cmp i dim1)
422	(uuo-error-array-bounds (:? hs) i header)
423	(ldr dim1 (:@ header (:$ (+ arm::misc-data-offset (* 4 (1+ arm::arrayH.dim0-cell))))))
424	(cmp j dim1)
425	(uuo-error-array-bounds (:? hs) i header)
426	(ldr dim2 (:@ header (:$ (+ arm::misc-data-offset (* 4 (+ 2 arm::arrayH.dim0-cell))))))
427	(cmp k dim2)
428	(uuo-error-array-bounds (:? hs) i header)
429	(mov dim1 (:asr dim1 (:$ arm::fixnumshift)))
430	(mov dim2 (:asr dim2 (:$ arm::fixnumshift))))
431
432	(define-arm-vinsn array-data-vector-ref (((dest :lisp))
433	((header :lisp)))
434	(ldr dest (:@ header (:$ arm::arrayH.data-vector))))
435
436
437	#+can-encode-array-rank-trap
438	(define-arm-vinsn check-arrayH-rank (()
439	((header :lisp)
440	(expected :u32const))
441	((rank :imm)))
442	(ldr rank (:@ header (:$ arm::arrayH.rank)))
443	(cmp rank (:apply ash expected arm::fixnumshift))
444	(uuo-error-bad-array-rank (:? ne) expected header))
445
446	#+can-remember-what-this-means
447	(define-arm-vinsn check-arrayH-flags (()
448	((header :lisp)
449	(expected :u16const))
450	((flags :imm)
451	(xreg :u32)))
452	(lis xreg (:apply ldb (byte 16 16) (:apply ash expected arm::fixnumshift)))
453	(ori xreg xreg (:apply ldb (byte 16 0) (:apply ash expected arm::fixnumshift)))
454	(lwz flags arm::arrayH.flags header)
455	(tw 27 flags xreg))
456
457
458
459
460
461	(define-arm-vinsn node-slot-ref (((dest :lisp))
462	((node :lisp)
463	(cellno :u32const)))
464	(ldr dest (:@ node (:$ (:apply + arm::misc-data-offset (:apply ash cellno 2))))))
465
466
467
468	(define-arm-vinsn %slot-ref (((dest :lisp))
469	((instance (:lisp (:ne dest)))
470	(index :lisp))
471	((scaled :u32)))
472	(add scaled index (:$ arm::misc-data-offset))
473	(ldr dest (:@ instance scaled))
474	(cmp dest (:$ arm::slot-unbound-marker))
475	(uuo-error-slot-unbound (:? eq) instance index))
476
477
478	;;; Untagged memory reference & assignment.
479
480	(define-arm-vinsn mem-ref-c-fullword (((dest :u32))
481	((src :address)
482	(index :s16const)))
483	(ldr dest (:@ src (:$ index))))
484
485
486	(define-arm-vinsn mem-ref-c-signed-fullword (((dest :s32))
487	((src :address)
488	(index :s16const)))
489	(ldr dest (:@ src (:$ index))))
490
491	(define-arm-vinsn mem-ref-c-natural (((dest :u32))
492	((src :address)
493	(index :s16const)))
494	(ldr dest (:@ src (:$ index))))
495
496
497	(define-arm-vinsn mem-ref-fullword (((dest :u32))
498	((src :address)
499	(index :s32)))
500	(ldr dest (:@ src index)))
501
502	(define-arm-vinsn mem-ref-signed-fullword (((dest :u32))
503	((src :address)
504	(index :s32)))
505	(ldr dest (:@ src index)))
506
507	(define-arm-vinsn mem-ref-natural (((dest :u32))
508	((src :address)
509	(index :s32)))
510	(ldr dest (:@ src index)))
511
512
513	(define-arm-vinsn mem-ref-c-u16 (((dest :u16))
514	((src :address)
515	(index :s16const)))
516	(ldrh dest (:@ src (:$ index))))
517
518
519	(define-arm-vinsn mem-ref-u16 (((dest :u16))
520	((src :address)
521	(index :s32)))
522	(ldrh dest (:@ src index)))
523
524
525
526	(define-arm-vinsn mem-ref-c-s16 (((dest :s16))
527	((src :address)
528	(index :s16const)))
529	(ldrsh dest (:@ src (:$ index))))
530
531	(define-arm-vinsn mem-ref-s16 (((dest :s16))
532	((src :address)
533	(index :s32)))
534	(ldrsh dest (:@ src index)))
535
536	(define-arm-vinsn mem-ref-c-u8 (((dest :u8))
537	((src :address)
538	(index :s16const)))
539	(ldrb dest (:@ src (:$ index))))
540
541	(define-arm-vinsn mem-ref-u8 (((dest :u8))
542	((src :address)
543	(index :s32)))
544	(ldrb dest (:@ src index)))
545
546	(define-arm-vinsn mem-ref-c-s8 (((dest :s8))
547	((src :address)
548	(index :s16const)))
549	(ldrsb dest (:@ src (:$ index))))
550
551	(define-arm-vinsn mem-ref-s8 (((dest :s8))
552	((src :address)
553	(index :s32)))
554	(ldrsb dest (:@ src index)))
555
556	#+notyet
557	(define-arm-vinsn mem-ref-c-bit (((dest :u8))
558	((src :address)
559	(byte-index :s16const)
560	(bit-shift :u8const)))
561	(lbz dest byte-index src)
562	(rlwinm dest dest bit-shift 31 31))
563
564
565	#+notyet
566	(define-arm-vinsn mem-ref-c-bit-fixnum (((dest :lisp))
567	((src :address)
568	(byte-index :s16const)
569	(bit-shift :u8const))
570	((byteval :u8)))
571	(lbz byteval byte-index src)
572	(rlwinm dest byteval bit-shift 29 29))
573
574	(define-arm-vinsn mem-ref-bit (((dest :u8))
575	((src :address)
576	(bit-index :lisp))
577	((byte-index :s16)
578	(bit-shift :u8)))
579
580	(mov byte-index (:lsr bit-index (:$ arm::fixnumshift)))
581	(and bit-shift byte-index (:$ 7))
582	(ldrb byte-index (:@ src (:lsr byte-index (:$ 5))))
583	(mov dest (:lsr byte-index bit-shift))
584	(and dest dest (:$ 1)))
585
586
587	(define-arm-vinsn mem-ref-bit-fixnum (((dest :lisp))
588	((src :address)
589	(bit-index :lisp))
590	((byte-index :s16)
591	(bit-shift :u8)))
592	(mov byte-index (:lsr bit-index (:$ arm::fixnumshift)))
593	(and bit-shift byte-index (:$ 7))
594	(ldrb byte-index (:@ src (:lsr byte-index (:$ 3))))
595	(mov byte-index (:lsr byte-index bit-shift))
596	(mov dest (:$ arm::fixnumone))
597	(and dest dest (:lsl byte-index (:$ arm::fixnumshift))))
598
599	(define-arm-vinsn mem-ref-c-double-float (((dest :double-float))
600	((src :address)
601	(index :s16const))
602	((low (:u32 #.arm::imm0))
603	(high (:u32 #.arm::imm1))))
604	(ldrd low (:@ src (:$ index)))
605	(fmdrr dest low high))
606
607	(define-arm-vinsn mem-ref-double-float (((dest :double-float))
608	((src :address)
609	(index :s32))
610	((low (:u32 #.arm::imm0))
611	(high (:u32 #.arm::imm1))))
612	(ldrd low (:@ src index))
613	(fmdrr dest low high))
614
615	(define-arm-vinsn mem-set-c-double-float (()
616	((val :double-float)
617	(src :address)
618	(index :s16const))
619	((low (:u32 #.arm::imm0))
620	(high (:u32 #.arm::imm1))))
621	(fmrrd low high src)
622	(strd low (:@ src (:$ index))))
623
624	(define-arm-vinsn mem-set-double-float (()
625	((val :double-float)
626	(src :address)
627	(index :s32)) ; imm2, I presume
628	((low (:u32 #.arm::imm0))
629	(high (:u32 #.arm::imm1))))
630	(fmrrd low high src)
631	(strd low (:@ src index)))
632
633	(define-arm-vinsn mem-ref-c-single-float (((dest :single-float))
634	((src :address)
635	(index :s16const))
636	((temp :u32)))
637	(ldr temp (:@ src (:$ index)))
638	(fmsr dest temp))
639
640	(define-arm-vinsn mem-ref-single-float (((dest :single-float))
641	((src :address)
642	(index :s32))
643	((temp :u32)))
644	(ldr temp (:@ src index))
645	(fmsr dest temp))
646
647	(define-arm-vinsn mem-set-c-single-float (()
648	((val :single-float)
649	(src :address)
650	(index :s16const))
651	((temp :u32)))
652	(fmrs temp src)
653	(str temp (:@ src (:$ index))))
654
655	(define-arm-vinsn mem-set-single-float (()
656	((val :single-float)
657	(src :address)
658	(index :s32))
659	((temp :u32)))
660	(fmrs temp src)
661	(str temp (:@ src (:$ index))))
662
663
664	(define-arm-vinsn mem-set-c-address (()
665	((val :address)
666	(src :address)
667	(index :s16const)))
668	(str val (:@ src (:$ index))))
669
670	(define-arm-vinsn mem-set-address (()
671	((val :address)
672	(src :address)
673	(index :s32)))
674	(str val (:@ src index)))
675
676	(define-arm-vinsn mem-set-c-fullword (()
677	((val :u32)
678	(src :address)
679	(index :s16const)))
680	(str val (:@ src (:$ index))))
681
682	(define-arm-vinsn mem-set-fullword (()
683	((val :u32)
684	(src :address)
685	(index :s32)))
686	(str val (:@ src index)))
687
688	(define-arm-vinsn mem-set-c-halfword (()
689	((val :u16)
690	(src :address)
691	(index :s16const)))
692	(strh val (:@ src (:$ index))))
693
694	(define-arm-vinsn mem-set-halfword (()
695	((val :u16)
696	(src :address)
697	(index :s32)))
698	(strh val (:@ src index)))
699
700	(define-arm-vinsn mem-set-c-byte (()
701	((val :u16)
702	(src :address)
703	(index :s16const)))
704	(strb val (:@ src (:$ index))))
705
706	(define-arm-vinsn mem-set-byte (()
707	((val :u8)
708	(src :address)
709	(index :s32)))
710	(strb val (:@ src index)))
711
712	(define-arm-vinsn mem-set-c-bit-0 (()
713	((src :address)
714	(byte-index :s16const)
715	(mask :u8const))
716	((val :u8)))
717	(ldrb val (:@ src (:$ byte-index)))
718	(bic val val (:$ mask))
719	(strb val (:@ src (:$ byte-index))))
720
721
722	(define-arm-vinsn mem-set-c-bit-1 (()
723	((src :address)
724	(byte-index :s16const)
725	(mask :u8const))
726	((val :u8)))
727	(ldrb val (:@ src (:$ byte-index)))
728	(orr val val (:$ mask))
729	(strb val (:@ src (:$ byte-index))))
730
731
732	(define-arm-vinsn mem-set-c-bit (()
733	((src :address)
734	(byte-index :s16const)
735	(bit-index :u8const)
736	(val :imm))
737	((byteval :u8)
738	(mask :u8)))
739	(mov mask (:$ 1))
740	(mov mask (:lsl mask bit-index))
741	(cmp val (:$ 0))
742	(ldrb byteval (:@ src (:$ byte-index)))
743	(orrne byteval byteval mask)
744	(biceq byteval byteval mask)
745	(strb byteval (:@ src (:$ byte-index)))
746	)
747
748	;;; Hey, they should be happy that it even works. Who cares how big it is or how
749	;;; long it takes ...
750	(define-arm-vinsn mem-set-bit (()
751	((src :address)
752	(bit-index :lisp)
753	(val :lisp))
754	((bit-shift :u32)
755	(mask :u32)))
756	(cmp val (:$ (ash 1 arm::fixnumshift)))
757	(mov bit-shift (:$ 7))
758	(mov mask (:$ 1))
759	(and bit-shift bit-shift (:lsr bit-index (:$ arm::fixnumshift)))
760	(mov mask (:lsl mask bit-shift))
761	(ldrb bit-shift (:@ src (:lsr bit-index (:$ (+ 3 arm::fixnumshift)))))
762	(uuo-error-reg-not-xtype (:? hi) val (:$ arm::xtype-bit))
763	(orrne bit-shift bit-shift mask)
764	(biceq bit-shift bit-shift mask)
765	(strb bit-shift (:@ src (:lsr bit-index (:$ (+ 3 arm::fixnumshift))))))
766
767	;;; Tag and subtag extraction, comparison, checking, trapping ...
768
769	(define-arm-vinsn extract-tag (((tag :u8))
770	((object :lisp))
771	())
772	(and tag object (:$ arm::tagmask)))
773
774	(define-arm-vinsn extract-tag-fixnum (((tag :imm))
775	((object :lisp)))
776	(and tag object (:$ arm::tagmask))
777	(mov tag (:lsl tag (:$ arm::fixnumshift))))
778
779	(define-arm-vinsn extract-fulltag (((tag :u8))
780	((object :lisp))
781	())
782	(and tag object (:$ arm::fulltagmask)))
783
784
785	(define-arm-vinsn extract-fulltag-fixnum (((tag :imm))
786	((object :lisp)))
787	(and tag object (:$ arm::fulltagmask))
788	(mov tag (:lsl tag (:$ arm::fixnumshift))))
789
790	(define-arm-vinsn extract-typecode (((code :u8))
791	((object :lisp))
792	())
793	(and code object (:$ arm::tagmask))
794	(cmp code (:$ arm::tag-misc))
795	(ldrbeq code (:@ object (:$ arm::misc-subtag-offset))))
796
797	(define-arm-vinsn extract-typecode-fixnum (((code :imm))
798	((object (:lisp (:ne code))))
799	((subtag :u8)))
800	(and subtag object (:$ arm::tagmask))
801	(cmp subtag (:$ arm::tag-misc))
802	(ldrbeq subtag (:@ object (:$ arm::misc-subtag-offset)))
803	(mov code (:lsl subtag (:$ arm::fixnumshift))))
804
805
806	;;; Can we assume that an error handler can retry this without our
807	;;; emitting a branch ? I'd like to think so.
808	(define-arm-vinsn require-fixnum (()
809	((object :lisp))
810	())
811	(tst object (:$ arm::tagmask))
812	(uuo-cerror-reg-not-lisptag (:? ne) object (:$ arm::tag-fixnum)))
813
814	(define-arm-vinsn require-integer (()
815	((object :lisp))
816	((tag :u8)))
817	(ands tag object (:$ arm::tagmask))
818	(beq :got-it)
819	(cmp tag (:$ arm::tag-misc))
820	(ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
821	(cmp tag (:$ arm::subtag-bignum))
822	(uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::xtype-integer))
823	:got-it)
824
825	(define-arm-vinsn require-simple-vector (()
826	((object :lisp))
827	((tag :u8)))
828	(and tag object (:$ arm::tagmask))
829	(cmp tag (:$ arm::tag-misc))
830	(ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
831	(cmp tag (:$ arm::subtag-simple-vector))
832	(uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::subtag-simple-vector)))
833
834	(define-arm-vinsn require-simple-string (()
835	((object :lisp))
836	((tag :u8)))
837	(and tag object (:$ arm::tagmask))
838	(cmp tag (:$ arm::tag-misc))
839	(ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
840	(cmp tag (:$ arm::subtag-simple-base-string))
841	(uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::subtag-simple-base-string)))
842
843
844	(define-arm-vinsn require-real (()
845	((object :lisp))
846	((tag :u8)))
847	(and tag object (:$ arm::tagmask))
848	(cmp tag (:$ arm::tag-misc))
849	(ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
850	(cmp tag (:$ arm::max-real-subtag))
851	(uuo-cerror-reg-not-xtype (:? hi) object (:$ arm::xtype-real)))
852
853	(define-arm-vinsn require-number (()
854	((object :lisp))
855	((tag :u8)))
856	(and tag object (:$ arm::tagmask))
857	(cmp tag (:$ arm::tag-misc))
858	(ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
859	(cmp tag (:$ arm::max-numeric-subtag))
860	(uuo-cerror-reg-not-xtype (:? hi) object (:$ arm::xtype-number)))
861
862
863	(define-arm-vinsn require-list (()
864	((object :lisp))
865	((tag :u8)))
866	(and tag object (:$ arm::tagmask))
867	(cmp tag (:$ arm::tag-list))
868	(uuo-cerror-reg-not-lisptag (:? ne) object (:$ arm::tag-list)))
869
870	(define-arm-vinsn require-symbol (()
871	((object :lisp))
872	((tag :u8)))
873	(and tag object (:$ arm::tagmask))
874	(cmp tag (:$ arm::tag-misc))
875	(ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
876	(cmpeq tag (:$ arm::subtag-symbol))
877	(cmpne object (:$ arm::nil-value))
878	(uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::subtag-symbol)))
879
880	(define-arm-vinsn require-character (()
881	((object :lisp))
882	((tag :u8)))
883	(and tag object (:$ arm::subtag-mask))
884	(cmp tag (:$ arm::subtag-character))
885	(uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::subtag-character)))
886
887
888	(define-arm-vinsn require-s8 (()
889	((object :lisp))
890	((tag :u32)))
891	(mov tag (:lsl object (:$ (- arm::nbits-in-word (+ 8 arm::fixnumshift)))))
892	(mov tag (:asr tag (:$ (- arm::nbits-in-word (+ 8 arm::fixnumshift)))))
893	(cmp object (:lsl tag (:$ arm::fixnumshift)))
894	(uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::xtype-s8)))
895
896
897	(define-arm-vinsn require-u8 (()
898	((object :lisp))
899	((temp :u32)))
900	(mov temp (:$ (lognot (ash #xff arm::fixnumshift))))
901	(tst object temp)
902	(uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::xtype-u8)))
903
904	(define-arm-vinsn require-s16 (()
905	((object :lisp))
906	( (tag :u32)))
907	(mov tag (:lsl object (:$ (- arm::nbits-in-word (+ 16 arm::fixnumshift)))))
908	(mov tag (:asr tag (:$ (- arm::nbits-in-word 16))))
909	(cmp object (:lsl tag (:$ arm::fixnumshift)))
910	(uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::xtype-s16)))
911
912	(define-arm-vinsn require-u16 (()
913	((object :lisp))
914	((tag :u32)))
915	(mov tag (:$ (lognot (ash #xff arm::fixnumshift))))
916	(bic tag tag (:$ (ash #xff (+ 8 arm::fixnumshift))))
917	(tst object tag)
918	(uuo-cerror-reg-not-xtype (:? ne) object (:$ arm::xtype-u16)))
919
920	(define-arm-vinsn require-s32 (()
921	((src :lisp))
922	((tag :u32)
923	(header :u32)))
924	(ands tag src (:$ arm::tagmask))
925	(beq :got-it)
926	(cmp tag (:$ arm::tag-misc))
927	(mov tag (:$ arm::subtag-bignum))
928	(orr tag tag (:$ (ash 1 arm::num-subtag-bits)))
929	(ldreq header (:@ src (:$ arm::misc-header-offset)))
930	(cmpeq tag header)
931	(uuo-cerror-reg-not-xtype (:? ne) src (:$ arm::xtype-s32))
932	:got-it)
933
934
935	(define-arm-vinsn require-u32 (()
936	((src :lisp))
937	((temp :u32)))
938	:again
939	(tst src (:$ (logior (ash 1 (1- arm::nbits-in-word)) arm::tagmask)))
940	(beq :got-it)
941	(and temp src (:$ arm::tagmask))
942	(cmp temp (:$ arm::tag-misc))
943	(ldrbeq temp (:@ src (:$ arm::misc-data-offset)))
944	(cmp temp (:$ arm::subtag-bignum))
945	(bne :bad-if-ne)
946	(ldr temp (:@ src (:$ arm::misc-header-offset)))
947	(mov temp (:lsr temp (:$ arm::num-subtag-bits)))
948	(cmp temp (:$ 2))
949	(beq :two)
950	(cmp temp (:$ 1))
951	(bne :bad-if-ne)
952	(ldr temp (:@ src (:$ arm::misc-data-offset)))
953	(tst temp (:$ (ash 1 31)))
954	(b :bad-if-ne)
955	:two
956	(ldr temp (:@ src (:$ (+ 4 arm::misc-data-offset))))
957	(cmp temp (:$ 0))
958	:bad-if-ne
959	(uuo-cerror-reg-not-xtype (:? ne) src (:$ arm::xtype-u32))
960	:got-it)
961
962	(define-arm-vinsn require-s64 (()
963	((src :lisp))
964	((tag :u32)
965	(header :u32)))
966	(ands tag src (:$ arm::tag-mask))
967	(beq :got-it)
968	(cmp tag (:$ arm::tag-misc))
969	(ldreq header (:@ src (:$ arm::misc-header-offset)))
970	(andeq tag header (:$ arm::subtag-mask))
971	(cmp tag (:$ arm::subtag-bignum))
972	(mov header (:lsr header (:$ arm::num-subtag-bits)))
973	(bne :bad-if-ne)
974	(cmp header (:$ 1))
975	(beq :got-it)
976	(cmp header (:$ 2))
977	:bad-if-ne
978	(uuo-cerror-reg-not-xtype src (:$ arm::xtype-s64))
979	:got-it)
980
981	(define-arm-vinsn require-u64 (()
982	((src :lisp))
983	((temp :u32)
984	(header :u32)))
985	:again
986	(tst src (:$ (logior (ash 1 31) arm::fixnum-mask)))
987	(and temp src (:$ arm::fixnum-mask))
988	(beq :got-it)
989	(cmp temp (:$ arm::tag-misc))
990	(ldreq header (:@ src (:$ arm::misc-header-offset)))
991	(andeq temp src (:$ arm::subtag-mask))
992	(moveq header (:lsr header (:$ arm::num-subtag-bits)))
993	(cmpeq temp (:$ arm::subtag-bignum))
994	(bne :bad-if-ne)
995	(cmp header (:$ 3))
996	(ldreq temp (:@ src (:$ (+ arm::misc-data-offset 8))))
997	(beq :three)
998	(cmp header (:$ 2))
999	(ldreq temp (:@ src (:$ (+ arm::misc-data-offset 4))))
1000	(beq :sign-of-highword)
1001	(cmp header (:$ 1))
1002	(ldr temp (:@ src (:$ arm::misc-data-offset)))
1003	(bne :bad-if-ne)
1004	:sign-of-highword
1005	(tst temp (:$ (ash 1 31)))
1006	(b :bad-if-ne)
1007	:three
1008	(cmp temp (:$ 0))
1009	:bad-if-ne
1010	(uuo-cerror-reg-not-xtype (:? ne) src (:$ arm::xtype-s64))
1011	:got-it)
1012
1013
1014
1015
1016	(define-arm-vinsn require-char-code (()
1017	((object :lisp)))
1018	(tst object (:$ arm::fixnum-mask))
1019	(bne :bad)
1020	(cmp object (:$ (ash char-code-limit arm::fixnumshift)))
1021	(bls :got-it)
1022	:bad
1023	(uuo-error-reg-not-xtype (:? al) object (:$ arm::xtype-char-code))
1024	:got-it)
1025
1026
1027	(define-arm-vinsn box-fixnum (((dest :imm))
1028	((src :s32)))
1029	(mov dest (:lsl src (:$ arm::fixnumshift))))
1030
1031	(define-arm-vinsn fixnum->signed-natural (((dest :s32))
1032	((src :imm)))
1033	(mov dest (:asr src (:$ arm::fixnumshift))))
1034
1035	(define-arm-vinsn fixnum->unsigned-natural (((dest :u32))
1036	((src :imm)))
1037	(mov dest (:lsr src (:$ arm::fixnumshift))))
1038
1039	;;; An object is of type (UNSIGNED-BYTE 32) iff
1040	;;; a) it's of type (UNSIGNED-BYTE 30) (e.g., an unsigned fixnum)
1041	;;; b) it's a bignum of length 1 and the 0'th digit is positive
1042	;;; c) it's a bignum of length 2 and the sign-digit is 0.
1043
1044	(define-arm-vinsn unbox-u32 (((dest :u32))
1045	((src :lisp))
1046	((temp :u32)))
1047
1048	(tst src (:$ #x80000003))
1049	(mov dest (:lsr src (:$ arm::fixnumshift)))
1050	(beq :got-it)
1051	(and temp src (:$ arm::tagmask))
1052	(cmp temp (:$ arm::tag-misc))
1053	(uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-u32))
1054	(ldr dest (:@ src (:$ arm::misc-header-offset)))
1055	(mov temp (:$ arm::subtag-bignum))
1056	(orr temp temp (:$ (ash 1 arm::num-subtag-bits)))
1057	(cmp dest temp)
1058	(bne :maybe-two-digit)
1059	(ldr dest (:@ src (:$ arm::misc-data-offset)))
1060	(tst dest (:$ 31))
1061	(uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-u32))
1062	(b :got-it)
1063	:maybe-two-digit
1064	(add temp temp (:$ (ash 1 arm::num-subtag-bits)))
1065	(cmp dest temp)
1066	(ldreq temp (:@ src (:$ (+ arm::misc-data-offset 4))))
1067	(cmpeq temp (:$ 0))
1068	(ldreq dest (:@ src (:$ arm::misc-data-offset)))
1069	(uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-u32))
1070	:got-it)
1071
1072	;;; an object is of type (SIGNED-BYTE 32) iff
1073	;;; a) it's a fixnum
1074	;;; b) it's a bignum with exactly one digit.
1075
1076	(define-arm-vinsn unbox-s32 (((dest :s32))
1077	((src :lisp))
1078	((tag :u32)))
1079	(ands tag src (:$ arm::tagmask))
1080	(mov dest (:asr src (:$ arm::fixnumshift)))
1081	(beq :got-it)
1082	(mov dest (:$ arm::subtag-bignum))
1083	(orr dest dest (:$ (ash 1 arm::num-subtag-bits)))
1084	(cmp tag (:$ arm::tag-misc))
1085	(ldreq tag (:@ src (:$ arm::misc-header-offset)))
1086	(cmpeq dest tag)
1087	(ldreq dest (:@ src (:$ arm::misc-data-offset)))
1088	(uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-s32))
1089	:got-it)
1090
1091
1092
1093	(define-arm-vinsn unbox-u16 (((dest :u16))
1094	((src :lisp)))
1095	(mov dest (:lsl src (:$ (- 16 arm::fixnumshift))))
1096	(mov dest (:lsr dest (:$ 16)))
1097	(cmp src (:lsl dest (:$ arm::fixnumshift)))
1098	(uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-u16)))
1099
1100	(define-arm-vinsn unbox-s16 (((dest :s16))
1101	((src :lisp)))
1102	(mov dest (:lsl src (:$ (- arm::nbits-in-word (+ 16 arm::fixnumshift)))))
1103	(mov dest (:asr dest (:$ 16)))
1104	(cmp src (:lsl dest (:$ arm::fixnumshift)))
1105	(uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-s16)))
1106
1107
1108
1109	(define-arm-vinsn unbox-u8 (((dest :u8))
1110	((src :lisp)))
1111	(mov dest (:lsl dest (:$ (- 24 arm::fixnumshift))))
1112	(mov dest (:asr dest (:$ 24)))
1113	(cmp src (:lsl dest (:$ arm::fixnumshift)))
1114	(uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-u8)))
1115
1116	(define-arm-vinsn %unbox-u8 (((dest :u8))
1117	((src :lisp)))
1118	(mov dest (:$ #xff))
1119	(and dest dest (:lsr src (:$ arm::fixnumshift))))
1120
1121	(define-arm-vinsn unbox-s8 (((dest :s8))
1122	((src :lisp)))
1123	(mov dest (:lsl dest (:$ (- 24 arm::fixnumshift))))
1124	(mov dest (:asr dest (:$ 24)))
1125	(cmp src (:lsl dest (:$ arm::fixnumshift)))
1126	(uuo-error-reg-not-xtype (:? ne) src (:$ arm::xtype-s8)))
1127
1128	(define-arm-vinsn unbox-base-char (((dest :u32))
1129	((src :lisp)))
1130	(and dest src (:$ arm::subtag-mask))
1131	(cmp dest (:$ arm::subtag-character))
1132	(mov dest (:lsr src (:$ arm::charcode-shift)))
1133	(uuo-error-reg-not-xtype (:? ne) src (:$ arm::subtag-character)))
1134
1135
1136	(define-arm-vinsn unbox-bit (((dest :u32))
1137	((src :lisp)))
1138	(cmp src (:$ arm::fixnumone))
1139	(mov dest (:lsr src (:$ arm::fixnumshift)))
1140	(uuo-error-reg-not-xtype (:? hi) src (:$ arm::xtype-bit)))
1141
1142
1143
1144	(define-arm-vinsn fixnum->double (((dest :double-float))
1145	((src :lisp))
1146	((imm :s32)
1147	(temp :single-float)))
1148	(mov imm (:asr src (:$ arm::fixnumshift)))
1149	(fmsr temp imm)
1150	(fsitod dest temp))
1151
1152	(define-arm-vinsn fixnum->single (((dest :single-float))
1153	((src :lisp))
1154	((imm :s32)))
1155	(mov imm (:asr src (:$ arm::fixnumshift)))
1156	(fmsr dest imm)
1157	(fsitos dest dest))
1158
1159
1160	(define-arm-vinsn shift-left-variable-word (((dest :u32))
1161	((src :u32)
1162	(sh :u32)))
1163	(mov dest (:lsl src sh)))
1164
1165	(define-arm-vinsn u32logandc2 (((dest :u32))
1166	((x :u32)
1167	(y :u32)))
1168	(bic dest x y))
1169
1170	(define-arm-vinsn u32logior (((dest :u32))
1171	((x :u32)
1172	(y :u32)))
1173	(orr dest x y))
1174
1175	(define-arm-vinsn set-or-clear-bit (((dest :u32))
1176	((src :u32)
1177	(mask :u32)
1178	(crf :crf)))
1179	(bicne dest src mask)
1180	(orreq dest src mask))
1181
1182	(define-arm-vinsn complement-shift-count (((dest :u32))
1183	((src :u32)))
1184	(rsb dest src (:$ 32)))
1185
1186	(define-arm-vinsn extract-lowbyte (((dest :u32))
1187	((src :lisp)))
1188	(and dest src (:$ arm::subtag-mask)))
1189
1190
1191
1192
1193	(define-arm-vinsn trap-unless-fixnum (()
1194	((object :lisp)))
1195	(tst object (:$ arm::fixnummask))
1196	(uuo-error-reg-not-lisptag (:? ne) object (:$ arm::tag-fixnum)))
1197
1198	(define-arm-vinsn trap-unless-list (()
1199	((object :lisp))
1200	((tag :u8)))
1201	(and tag object (:$ arm::tagmask))
1202	(cmp tag (:$ arm::tag-list))
1203	(uuo-error-reg-not-lisptag (:? ne) object (:$ arm::tag-list)))
1204
1205	(define-arm-vinsn trap-unless-single-float (()
1206	((object :lisp))
1207	((tag :u8)))
1208	(and tag object (:$ arm::tagmask))
1209	(cmp tag (:$ arm::tag-misc))
1210	(ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
1211	(cmp tag (:$ arm::subtag-single-float))
1212	(uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-single-float)))
1213
1214	(define-arm-vinsn trap-unless-double-float (()
1215	((object :lisp))
1216	((tag :u8)))
1217	(and tag object (:$ arm::tagmask))
1218	(cmp tag (:$ arm::tag-misc))
1219	(ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
1220	(cmp tag (:$ arm::subtag-double-float))
1221	(uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-double-float)))
1222
1223
1224	(define-arm-vinsn trap-unless-array-header (()
1225	((object :lisp))
1226	((tag :u8)))
1227	(and tag object (:$ arm::tagmask))
1228	(cmp tag (:$ arm::tag-misc))
1229	(ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
1230	(cmp tag (:$ arm::subtag-arrayH))
1231	(uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-arrayH)))
1232
1233	(define-arm-vinsn trap-unless-macptr (()
1234	((object :lisp))
1235	((tag :u8)))
1236	(and tag object (:$ arm::tagmask))
1237	(cmp tag (:$ arm::tag-misc))
1238	(ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
1239	(cmp tag (:$ arm::subtag-macptr))
1240	(uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-macptr)))
1241
1242
1243
1244	(define-arm-vinsn trap-unless-uvector (()
1245	((object :lisp))
1246	((tag :u8)))
1247	(and tag object (:$ arm::tagmask))
1248	(cmp tag (:$ arm::tag-misc))
1249	(uuo-error-reg-not-lisptag (:? ne) object (:$ arm::tag-misc)))
1250
1251
1252
1253	(define-arm-vinsn trap-unless-character (()
1254	((object :lisp))
1255	((tag :u8)))
1256	(and tag object (:$ arm::subtag-mask))
1257	(cmp tag (:$ arm::subtag-character))
1258	(uuo-error-reg-not-xtype (:? ne) object (:$ arm::subtag-character)))
1259
1260	(define-arm-vinsn trap-unless-cons (()
1261	((object :lisp))
1262	((tag :u8)))
1263	(and tag object (:$ arm::fulltagmask))
1264	(cmp tag (:$ arm::fulltag-cons))
1265	(uuo-error-reg-not-fulltag (:? ne) object (:$ arm::fulltag-cons)))
1266
1267	(define-arm-vinsn trap-unless-typecode= (()
1268	((object :lisp)
1269	(tagval :u16const))
1270	((tag :u8)))
1271	(and tag object (:$ arm::tagmask))
1272	(cmp tag (:$ arm::tag-misc))
1273	(ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
1274	(cmp tag (:$ tagval))
1275	(uuo-error-reg-not-xtype (:? ne) object (:$ tagval)))
1276
1277	(define-arm-vinsn subtract-constant (((dest :imm))
1278	((src :imm)
1279	(const :s16const)))
1280	(sub dest src (:$ const)))
1281
1282
1283
1284	;; Bit-extraction & boolean operations
1285
1286
1287	;; For some mind-numbing reason, IBM decided to call the most significant
1288	;; bit in a 32-bit word "bit 0" and the least significant bit "bit 31"
1289	;; (this despite the fact that it's essentially a big-endian architecture
1290	;; (it was exclusively big-endian when this decision was made.))
1291	;; We'll probably be least confused if we consistently use this backwards
1292	;; bit ordering (letting things that have a "sane" bit-number worry about
1293	;; it at compile-time or run-time (subtracting the "sane" bit number from
1294	;; 31.))
1295
1296	#+later
1297	(define-arm-vinsn extract-variable-bit (((dest :u8))
1298	((src :u32)
1299	(bitnum :u8))
1300	())
1301	(rotlw dest src bitnum)
1302	(extrwi dest dest 1 0))
1303
1304
1305	(define-arm-vinsn extract-variable-bit-fixnum (((dest :lisp))
1306	((src :u32)
1307	(bitnum :u8))
1308	((temp :u32)))
1309	(mov temp (:lsr src bitnum))
1310	(mov dest (:$ arm::fixnumone))
1311	(and dest dest (:lsl temp (:$ arm::fixnumshift))))
1312
1313
1314
1315
1316
1317
1318
1319	(define-arm-vinsn compare (((crf :crf))
1320	((arg0 t)
1321	(arg1 t))
1322	())
1323	(cmp arg0 arg1))
1324
1325	(define-arm-vinsn compare-to-nil (((crf :crf))
1326	((arg0 t)))
1327	(cmp arg0 (:$ arm::nil-value)))
1328
1329	(define-arm-vinsn compare-logical (((crf :crf))
1330	((arg0 t)
1331	(arg1 t))
1332	())
1333	(cmp arg0 arg1))
1334
1335	(define-arm-vinsn compare-immediate (((crf :crf))
1336	((arg t)
1337	(imm :u32const)))
1338	(cmp arg (:$ imm)))
1339
1340	(define-arm-vinsn double-float-compare (((crf :crf))
1341	((arg0 :double-float)
1342	(arg1 :double-float))
1343	())
1344	(fcmped arg0 arg1)
1345	(fmstat))
1346
1347
1348	(define-arm-vinsn double-float+-2 (((result :double-float))
1349	((x :double-float)
1350	(y :double-float)))
1351	(faddd result x y))
1352
1353	(define-arm-vinsn double-float--2 (((result :double-float))
1354	((x :double-float)
1355	(y :double-float)))
1356	(fsubd result x y))
1357
1358	(define-arm-vinsn double-float*-2 (((result :double-float))
1359	((x :double-float)
1360	(y :double-float)))
1361	(fmuld result x y))
1362
1363	(define-arm-vinsn double-float/-2 (((result :double-float))
1364	((x :double-float)
1365	(y :double-float)))
1366	(fdivd result x y))
1367
1368
1369	(define-arm-vinsn single-float-compare (((crf :crf))
1370	((arg0 :single-float)
1371	(arg1 :single-float))
1372	())
1373	(fcmpes arg0 arg1)
1374	(fmstat))
1375
1376	(define-arm-vinsn single-float+-2 (((result :single-float))
1377	((x :single-float)
1378	(y :single-float))
1379	())
1380	(fadds result x y))
1381
1382	(define-arm-vinsn single-float--2 (((result :single-float))
1383	((x :single-float)
1384	(y :single-float)))
1385	(fsubs result x y))
1386
1387	(define-arm-vinsn single-float*-2 (((result :single-float))
1388	((x :single-float)
1389	(y :single-float)))
1390	(fmuls result x y))
1391
1392	(define-arm-vinsn single-float/-2 (((result :single-float))
1393	((x :single-float)
1394	(y :single-float)))
1395	(fdivs result x y))
1396
1397
1398
1399
1400
1401	(define-arm-vinsn compare-unsigned (()
1402	((arg0 :imm)
1403	(arg1 :imm))
1404	())
1405	(cmp arg0 arg1))
1406
1407
1408
1409
1410
1411	;; Extract a constant bit (0-31) from src; make it be bit 31 of dest.
1412	;; Bitnum is treated mod 32.
1413	#+later
1414	(define-arm-vinsn extract-constant-arm-bit (((dest :u32))
1415	((src :imm)
1416	(bitnum :u16const))
1417	())
1418	(rlwinm dest src (:apply + 1 bitnum) 31 31))
1419
1420
1421
1422	(define-arm-vinsn set-constant-arm-bit-to-variable-value (((dest :u32))
1423	((src :u32)
1424	(bitval :u32) ; 0 or 1
1425	(bitnum :u8const)))
1426	(cmp bitval (:$ 0))
1427	(biceq dest src (:$ (:apply ash 1 bitnum)))
1428	(orrne dest src (:$ (:apply ash 1 bitnum))))
1429
1430	(define-arm-vinsn set-constant-arm-bit-to-1 (((dest :u32))
1431	((src :u32)
1432	(bitnum :u8const)))
1433	(orr dest src (:$ (:apply ash 1 bitnum))))
1434
1435
1436	(define-arm-vinsn set-constant-arm-bit-to-0 (((dest :u32))
1437	((src :u32)
1438	(bitnum :u8const)))
1439	(bic dest src (:$ (:apply ash 1 bitnum))))
1440
1441
1442	#+later
1443	(define-arm-vinsn insert-bit-0 (((dest :u32))
1444	((src :u32)
1445	(val :u32)))
1446	(rlwimi dest val 0 0 0))
1447
1448	;;; The bit number is boxed and wants to think of the least-significant bit as 0.
1449	;;; Imagine that.
1450	;;; To turn the boxed, lsb-0 bitnumber into an unboxed, msb-0 rotate count,
1451	;;; we (conceptually) unbox it, add arm::fixnumshift to it, subtract it from
1452	;;; 31, and add one. This can also be done as "unbox and subtract from 28",
1453	;;; I think ...
1454	;;; Actually, it'd be "unbox, then subtract from 30".
1455	#+later
1456	(define-arm-vinsn extract-variable-non-insane-bit (((dest :u32))
1457	((src :imm)
1458	(bit :imm))
1459	((temp :u32)))
1460	(srwi temp bit arm::fixnumshift)
1461	(subfic temp temp (- 32 arm::fixnumshift))
1462	(rlwnm dest src temp 31 31))
1463
1464	;;; Operations on lists and cons cells
1465
1466	(define-arm-vinsn %cdr (((dest :lisp))
1467	((src :lisp)))
1468	(ldr dest (:@ src (:$ arm::cons.cdr))))
1469
1470	(define-arm-vinsn %car (((dest :lisp))
1471	((src :lisp)))
1472	(ldr dest (:@ src (:$ arm::cons.car))))
1473
1474	(define-arm-vinsn %set-car (()
1475	((cell :lisp)
1476	(new :lisp)))
1477	(str cell (:@ new (:$ arm::cons.car))))
1478
1479	(define-arm-vinsn %set-cdr (()
1480	((cell :lisp)
1481	(new :lisp)))
1482	(str cell (:@ new (:$ arm::cons.cdr))))
1483
1484
1485	(define-arm-vinsn load-adl (()
1486	((n :u32const)))
1487	(mov nargs (:$ (:apply logand #x00ff0000 n)))
1488	((:not (:pred = 0 (:apply logand #xff000000 n)))
1489	(orr nargs nargs (:$ (:apply logand #xff000000 n))))
1490	((:not (:pred = 0 (:apply logand #x0000ff00 n)))
1491	(orr nargs nargs (:$ (:apply logand #x0000ff00 n))))
1492	((:not (:pred = 0 (:apply logand #x000000ff n)))
1493	(orr nargs nargs (:$ (:apply logand #x000000ff n)))))
1494
1495	(define-arm-vinsn set-nargs (()
1496	((n :s16const)))
1497	(mov nargs (:$ (:apply ash n arm::word-shift))))
1498
1499	(define-arm-vinsn scale-nargs (()
1500	((nfixed :s16const)))
1501	((:pred > nfixed 0)
1502	(add nargs nargs (:$ (:apply - (:apply ash nfixed arm::word-shift))))))
1503
1504
1505
1506	(define-arm-vinsn (vpush-register :push :node :vsp)
1507	(()
1508	((reg :lisp)))
1509	(str reg (:@! vsp (:$ (- arm::node-size)))))
1510
1511	(define-arm-vinsn (vpush-register-arg :push :node :vsp :outgoing-argument)
1512	(()
1513	((reg :lisp)))
1514	(str reg (:@! vsp (:$ (- arm::node-size)))))
1515
1516	(define-arm-vinsn (vpush-xyz :push :node :vsp) (() ())
1517	(stmdb (:! vsp) (arg_z arg_y arg_x)))
1518
1519	(define-arm-vinsn (vpush-yz :push :node :vsp) (() ())
1520	(stmdb (:! vsp) (arg_z arg_y)))
1521
1522	(define-arm-vinsn (vpush-argregs :push :node :vsp) (()
1523	((num-fixed-args :u16const)))
1524	((:pred = num-fixed-args 0)
1525	(cmp nargs (:$ 0))
1526	(beq :done))
1527	((:pred < num-fixed-args 2)
1528	(cmp nargs (:$ (ash 2 arm::fixnumshift)))
1529	(strlo arg_z (:@! vsp (:$ (- arm::node-size))))
1530	(stmdbeq (:! vsp) (arg_z arg_y))
1531	(stmdbhi (:! vsp) (arg_z arg_y arg_x))
1532	:done)
1533	((:pred = num-fixed-args 2)
1534	(cmp nargs (:$ (ash 2 arm::fixnumshift)))
1535	(stmdbeq (:! vsp) (arg_z arg_y))
1536	(stmdbhi (:! vsp) (arg_z arg_y arg_x)))
1537	((:pred > num-fixed-args 2)
1538	(stmdb (:! vsp) (arg_z arg_y arg_x))))
1539
1540
1541	(define-arm-vinsn (vpop-register :pop :node :vsp)
1542	(((dest :lisp))
1543	())
1544	(ldr dest (:@+ vsp (:$ arm::node-size))))
1545
1546	(define-arm-vinsn (pop-argument-registers :pop :node :vsp) (()
1547	())
1548	(cmp nargs (:$ 0))
1549	(beq :done)
1550	(cmp nargs (:$ (* 2 arm::fixnumshift)))
1551	(ldrlt arg_z (:@+ vsp (:$ arm::node-size)))
1552	(ldmiaeq (:! vsp) (arg_z arg_y))
1553	(ldmiagt (:! vsp) (arg_z arg_y arg_x))
1554	:done)
1555
1556
1557
1558	(define-arm-vinsn copy-node-gpr (((dest :lisp))
1559	((src :lisp)))
1560	((:not (:pred =
1561	(:apply %hard-regspec-value dest)
1562	(:apply %hard-regspec-value src)))
1563	(mov dest src)))
1564
1565	(define-arm-vinsn copy-gpr (((dest t))
1566	((src t)))
1567	((:not (:pred =
1568	(:apply %hard-regspec-value dest)
1569	(:apply %hard-regspec-value src)))
1570	(mov dest src)))
1571
1572
1573	(define-arm-vinsn copy-fpr (((dest :double-float))
1574	((src :double-float)))
1575	((:not (:pred =
1576	(:apply %hard-regspec-value dest)
1577	(:apply %hard-regspec-value src)))
1578	(fcpyd dest src)))
1579
1580	(define-arm-vinsn vcell-ref (((dest :lisp))
1581	((vcell :lisp)))
1582	(ldr dest (:@ vcell (:$ arm::misc-data-offset))))
1583
1584
1585	(define-arm-vinsn make-vcell (((dest :lisp))
1586	((closed (:lisp :ne dest)))
1587	((header :u32)))
1588	(mov header (:$ arm::subtag-value-cell))
1589	(orr header header (:$ (ash arm::value-cell.element-count arm::num-subtag-bits)))
1590	(sub allocptr allocptr (:$ (- arm::value-cell.size arm::fulltag-misc)))
1591	(ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
1592	(cmp allocptr dest)
1593	(uuo-alloc-trap (:? lo))
1594	(str header (:@ allocptr (:$ arm::misc-header-offset)))
1595	(mov dest allocptr)
1596	(bic allocptr allocptr (:$ arm::fulltagmask))
1597	(str closed (:@ dest (:$ arm::value-cell.value))))
1598
1599	(define-arm-vinsn make-stack-vcell (((dest :lisp))
1600	((closed :lisp))
1601	((header :u32)))
1602	(mov header (:$ arm::subtag-value-cell))
1603	(orr header header (:$ (ash arm::value-cell.element-count arm::num-subtag-bits)))
1604	(stmdb (:! sp) (closed header)))
1605
1606	(define-arm-vinsn make-stack-cons (((dest :lisp))
1607	((car :lisp) (cdr :lisp))
1608	((header (:u32 #.arm::imm0))
1609	(zero (:u32 #.arm::imm1))))
1610	(mov header (:$ arm::subtag-simple-vector))
1611	(mov zero (:$ 0))
1612	(orr header header (:$ (ash 3 arm::num-subtag-bits)))
1613	((:pred <
1614	(:apply %hard-regspec-value cdr)
1615	(:apply %hard-regspec-value car))
1616	(stmdb (:! sp) (car cdr zero header)))
1617	((:not (:pred <
1618	(:apply %hard-regspec-value cdr)
1619	(:apply %hard-regspec-value car)))
1620	(stmdb (:! sp) (cdr car zero header))
1621	(str car (:@ sp (:$ 12)))
1622	(str cdr (:@ sp (:$ 8))))
1623	(add dest sp (:$ (+ arm::dnode-size arm::fulltag-cons))))
1624
1625
1626	(define-arm-vinsn %closure-code% (((dest :lisp))
1627	())
1628	(mov dest (:$ arm::nil-value))
1629	(ldr dest (:@ dest (:$ (:apply + arm::symbol.vcell (arm::nrs-offset %closure-code%))))))
1630
1631
1632	(define-arm-vinsn single-float-bits (((dest :u32))
1633	((src :lisp)))
1634	(ldr dest (:@ src (:$ arm::single-float.value))))
1635
1636	(define-arm-vinsn (call-subprim :call :subprim-call) (()
1637	((spno :s32const)))
1638	(bl spno))
1639
1640	(define-arm-vinsn (jump-subprim :jumpLR) (()
1641	((spno :s32const)))
1642	(ba spno))
1643
1644	;;; Same as "call-subprim", but gives us a place to
1645	;;; track args, results, etc.
1646	(define-arm-vinsn (call-subprim-0 :call :subprim-call) (((dest t))
1647	((spno :s32const)))
1648	(bl spno))
1649
1650	(define-arm-vinsn (call-subprim-1 :call :subprim-call) (((dest t))
1651	((spno :s32const)
1652	(z t)))
1653	(bl spno))
1654
1655	(define-arm-vinsn (call-subprim-2 :call :subprim-call) (((dest t))
1656	((spno :s32const)
1657	(y t)
1658	(z t)))
1659	(bl spno))
1660
1661	(define-arm-vinsn (call-subprim-3 :call :subprim-call) (((dest t))
1662	((spno :s32const)
1663	(x t)
1664	(y t)
1665	(z t)))
1666	(bl spno))
1667
1668
1669
1670	(define-arm-vinsn ref-interrupt-level (((dest :imm))
1671	()
1672	((temp :u32)))
1673	(ldr temp (:@ rcontext (:$ arm::tcr.tlb-pointer)))
1674	(ldr dest (:@ temp (:$ arm::INTERRUPT-LEVEL-BINDING-INDEX))))
1675
1676
1677	;;; Unconditional (pc-relative) branch
1678	(define-arm-vinsn (jump :jump) (()
1679	((label :label)))
1680	(b label))
1681
1682	(define-arm-vinsn (call-label :call) (()
1683	((label :label)))
1684	(bl label))
1685
1686	;;; just like JUMP, only (implicitly) asserts that the following
1687	;;; code is somehow reachable.
1688	(define-arm-vinsn (non-barrier-jump :xref) (()
1689	((label :label)))
1690	(b label))
1691
1692
1693	(define-arm-vinsn (cbranch-true :branch) (()
1694	((label :label)
1695	(crf :crf)
1696	(crbit :u8const)))
1697	(b (:? crbit) label))
1698
1699	(define-arm-vinsn (cbranch-false :branch) (()
1700	((label :label)
1701	(crf :crf)
1702	(crbit :u8const)))
1703	(b (:~ crbit) label))
1704
1705	(define-arm-vinsn cond->boolean (((dest :imm))
1706	((cond :u8const)))
1707	(mov dest (:$ arm::nil-value))
1708	(add (:? cond) dest dest (:$ arm::t-offset)))
1709
1710
1711
1712	(define-arm-vinsn lisp-word-ref (((dest t))
1713	((base t)
1714	(offset t)))
1715	(ldr dest (:@ base offset)))
1716
1717	(define-arm-vinsn lisp-word-ref-c (((dest t))
1718	((base t)
1719	(offset :s16const)))
1720	(ldr dest (:@ base (:$ offset))))
1721
1722
1723
1724	;; Load an unsigned, 32-bit constant into a destination register.
1725	(define-arm-vinsn (lri :constant-ref) (((dest :imm))
1726	((intval :u32const))
1727	())
1728	((:pred arm::encode-arm-immediate intval)
1729	(mov dest (:$ intval)))
1730	((:not (:pred arm::encode-arm-immediate intval))
1731	((:pred arm::encode-arm-immediate (:apply lognot intval))
1732	(mvn dest (:$ (:apply lognot intval))))
1733	((:not (:pred arm::encode-arm-immediate (:apply lognot intval)))
1734	((:and (:pred >= intval 0)
1735	(:pred < intval #x10000))
1736	(mov dest (:$ (:apply logand #xff00 intval)))
1737	((:not (:pred = 0 (:apply logand #xff intval)))))
1738	(orr dest dest (:$ (:apply logand #xff intval)))))
1739	((:not (:and (:pred >= intval 0)
1740	(:pred < intval #x10000)))
1741	(:data)
1742	:const
1743	(:word intval)
1744	(:code)
1745	(ldr dest :const)))
1746
1747
1748
1749
1750
1751	(define-arm-vinsn alloc-eabi-c-frame (()
1752	((n-c-args :u16const))
1753	((header :u32)
1754	(size :imm)
1755	(prevsp :imm)))
1756	(mov header (:$ (:apply ash (:apply + 1 (:apply logandc2 (:apply + 4 1 n-c-args) 1)) arm::num-subtag-bits)))
1757	(mov size (:lsr header (:$ (- arm::num-subtag-bits arm::word-shift))))
1758	(orr header header (:$ arm::subtag-u32-vector))
1759	(mov prevsp sp)
1760	(add size size (:$ arm::node-size))
1761	(str header (:-@! sp size))
1762	(str prevsp (:@ sp (:$ 4))))
1763
1764	(define-arm-vinsn alloc-variable-c-frame (()
1765	((n-c-args :lisp))
1766	((header :u32)
1767	(size :imm)
1768	(prevsp :imm)))
1769	(add size n-c-args (:$ (ash (+ 4 1) arm::word-shift)))
1770	(bic size size (:$ arm::fixnumone))
1771	(add size size (:$ arm::fixnumone))
1772	(mov prevsp sp)
1773	(mov header (:lsl size (:$ (- arm::num-subtag-bits arm::fixnumshift))))
1774	(add size size (:$ arm::fixnumone))
1775	(orr header header (:$ arm::subtag-u32-vector))
1776	(str header (:-@! sp size))
1777	(str prevsp (:@ sp (:$ 4))))
1778
1779
1780
1781	;;; We should rarely have to do this - (#_foo x y (if .. (return-from ...)))
1782	;;; is one of the few cases that I can think of - but if we ever do, we
1783	;;; might as well exploit the fact that we stored the previous sp at
1784	;;; offset 4 in the C frame.
1785	(define-arm-vinsn (discard-c-frame :csp :pop :discard) (()
1786	())
1787	(ldr sp (:@ sp (:$ 4))))
1788
1789
1790
1791
1792	(define-arm-vinsn set-eabi-c-arg (()
1793	((argval :u32)
1794	(argnum :u16const)))
1795	(str argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift))))))
1796
1797
1798	(define-arm-vinsn set-single-eabi-c-arg (()
1799	((argval :single-float)
1800	(argnum :u16const)))
1801	(fsts argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift))))))
1802
1803	(define-arm-vinsn set-double-eabi-c-arg (()
1804	((argval :double-float)
1805	(argnum :u16const)))
1806	(fstd argval (:@ sp (:$ (:apply + arm::dnode-size (:apply ash argnum arm::word-shift))))))
1807
1808
1809
1810	(define-arm-vinsn (load-nil :constant-ref) (((dest t))
1811	())
1812	(mov dest (:$ arm::nil-value)))
1813
1814	(define-arm-vinsn (load-t :constant-ref) (((dest t))
1815	())
1816	(mov dest (:$ arm::nil-value))
1817	(add dest dest (:$ arm::t-offset)))
1818
1819
1820
1821	(define-arm-vinsn (ref-constant :constant-ref) (((dest :lisp))
1822	((src :s16const)))
1823	(ldr dest (:@ fn (:$ (:apply + arm::misc-data-offset (:apply ash (:apply + src 2) 2))))))
1824
1825	(define-arm-vinsn ref-indexed-constant (((dest :lisp))
1826	((idxreg :s32)))
1827	(ldr dest (:@ arm::fn idxreg)))
1828
1829
1830	(define-arm-vinsn cons (((dest :lisp))
1831	((newcar :lisp)
1832	(newcdr :lisp))
1833	((allocbase :imm)))
1834	(sub allocptr allocptr (:$ (- arm::cons.size arm::fulltag-cons)))
1835	(ldr allocbase (:@ rcontext (:$ arm::tcr.save-allocbase)))
1836	(cmp allocptr allocbase)
1837	(uuo-alloc-trap (:? lo))
1838	(str newcdr (:@ allocptr (:$ arm::cons.cdr)))
1839	(str newcar (:@ allocptr (:$ arm::cons.car)))
1840	(mov dest allocptr)
1841	(bic allocptr allocptr (:$ arm::fulltagmask)))
1842
1843
1844
1845	;; subtag had better be a ARM-NODE-SUBTAG of some sort!
1846	(define-arm-vinsn %arm-gvector (((dest :lisp))
1847	((Rheader :u32)
1848	(nbytes :u32const))
1849	((immtemp0 :u32)
1850	(nodetemp :lisp)))
1851
1852	(sub allocptr allocptr (:$ (:apply logand #xff
1853	(:apply -
1854	(:apply logand (lognot 7)
1855	(:apply + (+ 7 4) nbytes))
1856	arm::fulltag-misc))))
1857	((:pred > (:apply -
1858	(:apply logand (lognot 7)
1859	(:apply + (+ 7 4) nbytes))
1860	arm::fulltag-misc) #xff)
1861	(sub allocptr allocptr (:$ (:apply logand #xff00
1862	(:apply -
1863	(:apply logand (lognot 7)
1864	(:apply + (+ 7 4) nbytes))
1865	arm::fulltag-misc)))))
1866	(ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
1867	(cmp allocptr dest)
1868	(uuo-alloc-trap (:? lo))
1869	(str Rheader (:@ allocptr (:$ arm::misc-header-offset)))
1870	(mov dest allocptr)
1871	(bic allocptr allocptr (:$ arm::fulltagmask))
1872	((:not (:pred = nbytes 0))
1873	(mov immtemp0 (:$ (:apply logand #xff (:apply + arm::misc-data-offset nbytes))))
1874	((:not (:pred = (:apply logand #xff00 (:apply + arm::misc-data-offset nbytes)) 0))
1875	(orr immtemp0 immtemp0 (:$ (:apply logand #xff00 (:apply + arm::misc-data-offset nbytes)))))
1876	:loop
1877	(sub immtemp0 immtemp0 (:$ 4))
1878	(cmp immtemp0 (:$ arm::misc-data-offset))
1879	(ldr nodetemp (:@+ vsp (:$ arm::node-size)))
1880	(str nodetemp (:@ dest immtemp0))
1881	(bne :loop)))
1882
1883	;; allocate a small (phys size <= 32K bytes) misc obj of known size/subtag
1884	(define-arm-vinsn %alloc-misc-fixed (((dest :lisp))
1885	((Rheader :u32)
1886	(nbytes :u32const)))
1887	(sub allocptr allocptr (:$ (:apply
1888	logand #xff
1889	(:apply - (:apply logand (lognot 7)
1890	(:apply + (+ 7 4) nbytes))
1891	arm::fulltag-misc))))
1892	((:pred > (:apply - (:apply logand (lognot 7)
1893	(:apply + (+ 7 4) nbytes))
1894	arm::fulltag-misc) #xff)
1895	(sub allocptr allocptr (:$ (:apply logand #xff00
1896	(:apply -
1897	(:apply logand (lognot 7)
1898	(:apply + (+ 7 4) nbytes))
1899	arm::fulltag-misc)))))
1900	(ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
1901	(cmp allocptr dest)
1902	(uuo-alloc-trap (:? lo))
1903	(str Rheader (:@ allocptr (:$ arm::misc-header-offset)))
1904	(mov dest allocptr)
1905	(bic allocptr allocptr (:$ arm::fulltagmask)))
1906
1907	(define-arm-vinsn (vstack-discard :vsp :pop :discard) (()
1908	((nwords :u32const)))
1909	((:not (:pred = nwords 0))
1910	(add vsp vsp (:$ (:apply ash nwords arm::word-shift)))))
1911
1912
1913	(define-arm-vinsn lcell-load (((dest :lisp))
1914	((cell :lcell)
1915	(top :lcell)))
1916	(ldr dest (:@ vsp (:$ (:apply -
1917	(:apply - (:apply calc-lcell-depth top) 4)
1918	(:apply calc-lcell-offset cell))))))
1919
1920	(define-arm-vinsn vframe-load (((dest :lisp))
1921	((frame-offset :u16const)
1922	(cur-vsp :u16const)))
1923	(ldr dest (:@ vsp (:$ (:apply - (:apply - cur-vsp 4) frame-offset)))))
1924
1925	(define-arm-vinsn lcell-store (()
1926	((src :lisp)
1927	(cell :lcell)
1928	(top :lcell)))
1929	(str src (:@ vsp (:$ (:apply -
1930	(:apply - (:apply calc-lcell-depth top) 4)
1931	(:apply calc-lcell-offset cell))))))
1932
1933	(define-arm-vinsn vframe-store (()
1934	((src :lisp)
1935	(frame-offset :u16const)
1936	(cur-vsp :u16const)))
1937	(str src (:@ vsp (:$ (:apply - (:apply - cur-vsp 4) frame-offset)))))
1938
1939	(define-arm-vinsn load-vframe-address (((dest :imm))
1940	((offset :s16const)))
1941	(add dest vsp (:$ offset)))
1942
1943	(define-arm-vinsn copy-lexpr-argument (()
1944	()
1945	((temp :lisp)))
1946	(ldr temp (:@ vsp nargs))
1947	(str temp (:@! vsp (:$ (- arm::node-size)))))
1948
1949	;;; Boxing/unboxing of integers.
1950
1951	;;; Treat the low 8 bits of VAL as an unsigned integer; set RESULT to the equivalent fixnum.
1952	(define-arm-vinsn u8->fixnum (((result :imm))
1953	((val :u8))
1954	())
1955	(mov result (:lsr val (:$ 24)))
1956	(mov result (:lsr val (:$ (- 24 arm::fixnumshift)))))
1957
1958	;;; Treat the low 8 bits of VAL as a signed integer; set RESULT to the equivalent fixnum.
1959	(define-arm-vinsn s8->fixnum (((result :imm))
1960	((val :s8))
1961	())
1962	(mov result (:lsr val (:$ 24)))
1963	(mov result (:asr val (:$ (- 24 arm::fixnumshift)))))
1964
1965
1966	;;; Treat the low 16 bits of VAL as an unsigned integer; set RESULT to the equivalent fixnum.
1967	(define-arm-vinsn u16->fixnum (((result :imm))
1968	((val :u16))
1969	())
1970	(mov result (:lsl val (:$ 16)))
1971	(mov result (:lsr result (:$ (- 16 arm::fixnumshift)))))
1972
1973	;;; Treat the low 16 bits of VAL as a signed integer; set RESULT to the equivalent fixnum.
1974	(define-arm-vinsn s16->fixnum (((result :imm))
1975	((val :s16))
1976	())
1977	(mov result (:lsl val (:$ 16)))
1978	(mov result (:asr result (:$ (- 16 arm::fixnumshift)))))
1979
1980	(define-arm-vinsn fixnum->s16 (((result :s16))
1981	((src :imm)))
1982	(mov result (:asr src (:$ arm::fixnumshift))))
1983
1984	;;; A signed 32-bit untagged value can be at worst a 1-digit bignum.
1985	;;; There should be something very much like this that takes a stack-consed
1986	;;; bignum result ...
1987	(define-arm-vinsn s32->integer (((result :lisp))
1988	((src :s32))
1989	((temp :s32)))
1990	(adds temp src src)
1991	(addsvc result temp temp)
1992	(bvc :done)
1993	(mov temp (:$ arm::subtag-bignum))
1994	(orr temp temp (:$ (ash 1 arm::num-subtag-bits)))
1995	(add allocptr allocptr (:$ (- arm::fulltag-misc 8)))
1996	(ldr result (:@ rcontext (:$ arm::tcr.save-allocbase)))
1997	(cmp allocptr result)
1998	(uuo-alloc-trap (:? lo))
1999	(str temp (:@ allocptr (:$ arm::misc-header-offset)))
2000	(mov result allocptr)
2001	(bic allocptr allocptr (:$ arm::fulltagmask))
2002	(str src (:@ result (:$ arm::misc-data-offset)))
2003	:done)
2004
2005
2006	;;; An unsigned 32-bit untagged value can be either a 1 or a 2-digit bignum.
2007	(define-arm-vinsn u32->integer (((result :lisp))
2008	((src :u32))
2009	((temp :s32)
2010	(size :u32)))
2011	(tst src (:$ #xe0000000))
2012	(moveq result (:lsr src (:$ arm::fixnumshift)))
2013	(beq :done)
2014	(cmp src (:$ 0))
2015	(mov temp (:$ arm::subtag-bignum))
2016	(movgt size (:$ (- (* 2 arm::dnode-size) arm::fulltag-misc)))
2017	(orrgt temp temp (:$ (ash 2 arm::num-subtag-bits)))
2018	(movlt size (:$ (- (* 1 arm::dnode-size) arm::fulltag-misc)))
2019	(orrlt temp temp (:$ (ash 1 arm::num-subtag-bits)))
2020	(sub allocptr allocptr size)
2021	(ldr result (:@ rcontext (:$ arm::tcr.save-allocbase)))
2022	(cmp allocptr result)
2023	(uuo-alloc-trap (:? lo))
2024	(str temp (:@ allocptr (:$ arm::misc-header-offset)))
2025	(mov result allocptr)
2026	(bic allocptr allocptr (:$ arm::fulltagmask))
2027	(str src (:@ result (:$ arm::misc-data-offset)))
2028	:done)
2029
2030	(define-arm-vinsn u16->u32 (((dest :u32))
2031	((src :u16)))
2032	(mov dest (:$ #xff))
2033	(orr dest dest (:$ #xff00))
2034	(and dest dest src))
2035
2036	(define-arm-vinsn u8->u32 (((dest :u32))
2037	((src :u8)))
2038	(and dest src (:$ #xff)))
2039
2040
2041	(define-arm-vinsn s16->s32 (((dest :s32))
2042	((src :s16)))
2043	(mov dest (:lsl src (:$ 16)))
2044	(mov dest (:asr src (:$ 16))))
2045
2046	(define-arm-vinsn s8->s32 (((dest :s32))
2047	((src :s8)))
2048	(mov dest (:lsl src (:$ 24)))
2049	(mov dest (:asr src (:$ 24))))
2050
2051
2052	;;; ... of floats ...
2053
2054	;;; Heap-cons a double-float to store contents of FPREG. Hope that we don't do
2055	;;; this blindly.
2056	(define-arm-vinsn double->heap (((result :lisp)) ; tagged as a double-float
2057	((fpreg :double-float))
2058	((header-temp (:u32 #.arm::imm0))
2059	(high (:u32 #.arm::imm1))))
2060	(mov header-temp (:$ arm::subtag-double-float))
2061	(orr header-temp header-temp (:$ (ash arm::double-float.element-count arm::num-subtag-bits)))
2062	(sub allocptr allocptr (:$ (- arm::double-float.size arm::fulltag-misc)))
2063	(ldr result (:@ rcontext (:$ arm::tcr.save-allocbase)))
2064	(cmp allocptr result)
2065	(uuo-alloc-trap (:? lo))
2066	(str header-temp (:@ allocptr (:$ arm::misc-header-offset)))
2067	(mov result allocptr)
2068	(bic allocptr allocptr (:$ arm::fulltagmask))
2069	(fmrrd header-temp high fpreg)
2070	(strd header-temp (:@ result (:$ arm::double-float.value))))
2071
2072
2073	;;; This is about as bad as heap-consing a double-float. (In terms of
2074	;;; verbosity). Wouldn't kill us to do either/both out-of-line, but
2075	;;; need to make visible to compiler so unnecessary heap-consing can
2076	;;; be elided.
2077	(define-arm-vinsn single->node (((result :lisp)) ; tagged as a single-float
2078	((fpreg :single-float))
2079	((header-temp :u32)))
2080	(mov header-temp (:$ arm::subtag-single-float))
2081	(orr header-temp header-temp (:$ (ash arm::single-float.element-count arm::num-subtag-bits)))
2082	(sub allocptr allocptr (:$ (- arm::single-float.size arm::fulltag-misc)))
2083	(ldr result (:@ rcontext (:$ arm::tcr.save-allocbase)))
2084	(cmp allocptr result)
2085	(uuo-alloc-trap (:? lo))
2086	(str header-temp (:@ allocptr (:$ arm::misc-header-offset)))
2087	(mov result allocptr)
2088	(bic allocptr allocptr (:$ arm::fulltagmask))
2089	(fmrs header-temp fpreg)
2090	(str header-temp (:@ result (:$ arm::single-float.value))))
2091
2092
2093
2094	;;; "dest" is preallocated, presumably on a stack somewhere.
2095	(define-arm-vinsn store-double (()
2096	((dest :lisp)
2097	(source :double-float))
2098	((low (:u32 #.arm::imm0))
2099	(high (:u32 #.arm::imm1))))
2100	(fmrrd low high source)
2101	(str low (:@ dest (:$ arm::double-float.value))))
2102
2103	(define-arm-vinsn get-double (((target :double-float))
2104	((source :lisp))
2105	((low (:u32 #.arm::imm0))
2106	(high (:u32 #.arm::imm1))))
2107	(ldrd low (:@ source (:$ arm::double-float.value)))
2108	(fmdrr target low high))
2109
2110	;;; Extract a double-float value, typechecking in the process.
2111	;;; IWBNI we could simply call the "trap-unless-typecode=" vinsn here,
2112	;;; instead of replicating it ..
2113
2114	(define-arm-vinsn get-double? (((target :double-float))
2115	((source :lisp))
2116	((low (:u32 #.arm::imm0))
2117	(high (:u32 #.arm::imm1))))
2118	(and low source (:$ arm::tagmask))
2119	(cmp low (:$ arm::tag-misc))
2120	(ldrbeq low (:@ source (:$ arm::misc-subtag-offset)))
2121	(cmp imm0 (:$ arm::subtag-double-float))
2122	(uuo-error-reg-not-xtype (:? ne) source (:$ arm::subtag-double-float))
2123	(ldrd imm0 (:@ source (:$ arm::double-float.value)))
2124	(fmdrr target imm0 imm1))
2125
2126
2127	(define-arm-vinsn double-to-single (((result :single-float))
2128	((arg :double-float)))
2129	(fcvtsd result arg))
2130
2131	(define-arm-vinsn store-single (()
2132	((dest :lisp)
2133	(source :single-float))
2134	((temp :u32)))
2135	(fmrs temp source)
2136	(str temp (:@ dest (:$ arm::single-float.value))))
2137
2138	(define-arm-vinsn get-single (((target :single-float))
2139	((source :lisp))
2140	((temp :u32)))
2141	(ldr temp (:@ source (:$ arm::single-float.value)))
2142	(fmsr target temp))
2143
2144	;;; ... of characters ...
2145
2146
2147	(define-arm-vinsn character->fixnum (((dest :lisp))
2148	((src :lisp))
2149	())
2150	(bic dest src (:$ arm::subtag-mask))
2151	(mov dest (:lsr dest (:$ (- arm::ncharcodebits arm::fixnumshift)))))
2152
2153	(define-arm-vinsn character->code (((dest :u32))
2154	((src :lisp)))
2155	(mov dest (:lsr src (:$ arm::charcode-shift))))
2156
2157
2158	(define-arm-vinsn fixnum->char (((dest :lisp))
2159	((src :imm))
2160	((temp :u32)
2161	(temp2 :u32)))
2162	(mov temp2 (:$ #x7f00))
2163	(mov temp (:lsr src (:$ (+ arm::fixnumshift 1))))
2164	(orr temp2 temp2 (:$ #xff))
2165	(cmp temp temp2)
2166	(mov temp (:lsr src (:$ (+ arm::fixnumshift 11))))
2167	(beq :bad)
2168	(cmp temp (:$ 27))
2169	(mov dest (:lsr src (:$ (- arm::charcode-shift arm::fixnumshift))))
2170	:bad
2171	(moveq dest (:$ arm::nil-value))
2172	(addne dest dest (:$ arm::subtag-character)))
2173
2174	;;; src is known to be a code for which CODE-CHAR returns non-nil.
2175	(define-arm-vinsn code-char->char (((dest :lisp))
2176	((src :imm))
2177	())
2178	(mov dest (:lsl src (:$ (- arm::charcode-shift arm::fixnum-shift))))
2179	(orr dest dest (:$ arm::subtag-character)))
2180
2181	(define-arm-vinsn u32->char (((dest :lisp))
2182	((src :u32))
2183	())
2184	(mov dest (:lsl src (:$ arm::charcode-shift)))
2185	(orr dest dest (:$ arm::subtag-character)))
2186
2187	;; ... Macptrs ...
2188
2189	(define-arm-vinsn deref-macptr (((addr :address))
2190	((src :lisp))
2191	())
2192	(ldr addr (:@ src (:$ arm::macptr.address))))
2193
2194	(define-arm-vinsn set-macptr-address (()
2195	((addr :address)
2196	(src :lisp))
2197	())
2198	(str addr (:@ src (:$ arm::macptr.address))))
2199
2200
2201	(define-arm-vinsn macptr->heap (((dest :lisp))
2202	((address :address))
2203	((header :u32)))
2204	(mov header (:$ arm::subtag-macptr))
2205	(orr header header (:$ (ash arm::macptr.element-count arm::num-subtag-bits)))
2206	(sub allocptr allocptr (:$ (- arm::macptr.size arm::fulltag-misc)))
2207	(ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
2208	(cmp allocptr dest)
2209	(uuo-alloc-trap (:? lo))
2210	(str header (:@ allocptr (:$ arm::misc-header-offset)))
2211	(mov dest allocptr)
2212	(bic allocptr allocptr (:$ arm::fulltagmask))
2213	;; It's not necessary to zero out the domain/type fields, since newly
2214	;; heap-allocated memory's guaranteed to be 0-filled.
2215	(str address (:@ dest (:$ arm::macptr.address))))
2216
2217	(define-arm-vinsn macptr->stack (((dest :lisp))
2218	((address :address))
2219	((header :u32)))
2220	(mov header (:$ arm::subtag-macptr))
2221	(orr header header (:$ (ash arm::macptr.element-count arm::num-subtag-bits)))
2222	(str header (:@! sp (:$ (- arm::macptr.size))))
2223	(mov header (:$ 0))
2224	(str header (:@ sp (:$ (+ arm::fulltag-misc arm::macptr.domain))))
2225	(str header (:@ sp (:$ (+ arm::fulltag-misc arm::macptr.type))))
2226	(str address (:@ sp (:$ (+ arm::fulltag-misc arm::macptr.address))))
2227	(add dest sp (:$ arm::fulltag-misc)))
2228
2229
2230
2231	(define-arm-vinsn adjust-stack-register (()
2232	((reg t)
2233	(amount :s16const)))
2234	(add reg reg (:$ amount)))
2235
2236	(define-arm-vinsn adjust-vsp (()
2237	((amount :s16const)))
2238	(add vsp vsp (:$ amount)))
2239
2240	(define-arm-vinsn adjust-sp (()
2241	((amount :s16const)))
2242	(add sp sp (:$ amount)))
2243
2244	;; Arithmetic on fixnums & unboxed numbers
2245
2246	(define-arm-vinsn u32-lognot (((dest :u32))
2247	((src :u32))
2248	())
2249	(mvn dest src))
2250
2251	(define-arm-vinsn fixnum-lognot (((dest :imm))
2252	((src :imm))
2253	((temp :u32)))
2254	(mvn temp src)
2255	(bic dest temp (:$ arm::fixnummask)))
2256
2257
2258	(define-arm-vinsn negate-fixnum-overflow-inline (((dest :lisp))
2259	((src :imm))
2260	((unboxed :s32)
2261	(header :u32)))
2262	(rsbs dest src (:$ 0))
2263	(bvc :done)
2264	(mov unboxed (:asr dest (:$ arm::fixnumshift)))
2265	(eor unboxed unboxed (:$ #xc0000000))
2266	(mov header (:$ arm::subtag-bignum))
2267	(orr header header (:$ (ash 1 arm::num-subtag-bits)))
2268	(sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc)))
2269	(ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
2270	(cmp allocptr dest)
2271	(uuo-alloc-trap (:? lo))
2272	(str header (:@ allocptr (:$ arm::misc-header-offset)))
2273	(mov dest allocptr)
2274	(bic allocptr allocptr (:$ arm::fulltagmask))
2275	(str unboxed (:@ dest (:$ arm::misc-data-offset)))
2276	:done)
2277
2278	(define-arm-vinsn negate-fixnum-overflow-ool (()
2279	((src :imm))
2280	)
2281	(rsbs arm::arg_z src (:$ 0))
2282	(blvs .SPfix-overflow))
2283
2284
2285
2286	(define-arm-vinsn negate-fixnum-no-ovf (((dest :lisp))
2287	((src :imm)))
2288
2289	(rsb dest src (:$ 0)))
2290
2291
2292	(define-arm-vinsn logior-immediate (((dest :imm))
2293	((src :imm)
2294	(imm :u32const)))
2295	(orr dest src (:$ imm)))
2296
2297
2298
2299	(define-arm-vinsn %logior2 (((dest :imm))
2300	((x :imm)
2301	(y :imm))
2302	())
2303	(orr dest x y))
2304
2305	(define-arm-vinsn logand-immediate (((dest :imm))
2306	((src :imm)
2307	(imm :u32const)))
2308	(and dest src (:$ imm)))
2309
2310
2311	(define-arm-vinsn %logand2 (((dest :imm))
2312	((x :imm)
2313	(y :imm))
2314	())
2315	(and dest x y))
2316
2317	(define-arm-vinsn logxor-immediate (((dest :imm))
2318	((src :imm)
2319	(imm :u32const)))
2320	(eor dest src (:$ imm)))
2321
2322
2323
2324
2325	(define-arm-vinsn %logxor2 (((dest :imm))
2326	((x :imm)
2327	(y :imm))
2328	())
2329	(eor dest x y))
2330
2331	;;; ARM register shifts shift by the low byte of RS.
2332	(define-arm-vinsn %ilsl (((dest :imm))
2333	((count :imm)
2334	(src :imm))
2335	((temp :u32)))
2336	(mov temp (:asr count (:$ arm::fixnumshift)))
2337	(mov dest (:lsl src temp)))
2338
2339	;;; Shift by a constant = -> shift by 32. Don't do that.
2340	(define-arm-vinsn %ilsl-c (((dest :imm))
2341	((count :u8const)
2342	(src :imm)))
2343	((:pred = count 0)
2344	(mov dest src))
2345	((:not (:pred = count 0))
2346	(mov dest (:lsl src (:$ (:apply logand count 31))))))
2347
2348
2349	(define-arm-vinsn %ilsr-c (((dest :imm))
2350	((count :u8const)
2351	(src :imm))
2352	((temp :s32)))
2353	(mov temp (:lsr src (:$ count)))
2354	(bic dest temp (:$ arm::fixnummask)))
2355
2356
2357	(define-arm-vinsn %iasr (((dest :imm))
2358	((count :imm)
2359	(src :imm))
2360	((temp :s32)))
2361	(mov temp (:asr count (:$ arm::fixnumshift)))
2362	(mov temp (:asr src temp))
2363	(bic dest temp (:$ arm::fixnummask)))
2364
2365	(define-arm-vinsn %iasr-c (((dest :imm))
2366	((count :u8const)
2367	(src :imm))
2368	((temp :s32)))
2369	((:pred = count 0)
2370	(mov dest src))
2371	((:not (:pred = count 0))
2372	(mov temp (:asr src (:$ count)))
2373	(bic dest src (:$ arm::fixnummask))))
2374
2375	(define-arm-vinsn %ilsr (((dest :imm))
2376	((count :imm)
2377	(src :imm))
2378	((temp :s32)))
2379	(mov temp (:asr count (:$ arm::fixnumshift)))
2380	(mov temp (:lsr src temp))
2381	(bic dest temp (:$ arm::fixnummask)))
2382
2383
2384	(define-arm-vinsn %ilsr-c (((dest :imm))
2385	((count :u8const)
2386	(src :imm))
2387	((temp :s32)))
2388	((:pred = count 0)
2389	(mov dest src))
2390	((:not (:pred = count 0))
2391	(mov temp (:lsr src (:$ count)))
2392	(bic dest temp (:$ arm::fixnummask))))
2393
2394	(define-arm-vinsn natural-shift-left (((dest :u32))
2395	((src :u32)
2396	(count :u8const)))
2397	((:pred = count 0)
2398	(mov dest src))
2399	((:not (:pred = count 0))
2400	(mov dest (:lsl src (:$ count)))))
2401
2402	(define-arm-vinsn natural-shift-right (((dest :u32))
2403	((src :u32)
2404	(count :u8const)))
2405	((:pred = count 0)
2406	(mov dest src))
2407	((:not (:pred = count 0))
2408	(mov dest (:lsr src (:$ count)))))
2409
2410
2411	(define-arm-vinsn trap-unless-simple-array-2 (()
2412	((object :lisp)
2413	(expected-flags :u32const)
2414	(type-error :u8const))
2415	((tag :u8)
2416	(flags :u32)))
2417	(and tag object (:$ arm::tagmask))
2418	(cmp tag (:$ arm::tag-misc))
2419	(ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
2420	(cmp tag (:$ arm::subtag-arrayH))
2421	(bne :bad-if-ne)
2422	(ldr tag (:@ object (:$ arm::arrayH.rank)))
2423	(cmp tag (:$ (ash 2 arm::fixnumshift)))
2424	(bne :bad-if-ne)
2425	(mov tag (:$ (:apply ash (:apply logand expected-flags #xff00) arm::fixnumshift)))
2426	(orr tag tag (:$ (:apply ash (:apply logand expected-flags #x00ff) arm::fixnumshift)))
2427	(ldr flags (:@ object (:$ arm::arrayH.flags)))
2428	(cmp tag flags)
2429	:bad-if-ne
2430	(uuo-error-reg-not-xtype (:? ne) object (:$ type-error)))
2431
2432	(define-arm-vinsn trap-unless-simple-array-3 (()
2433	((object :lisp)
2434	(expected-flags :u16const)
2435	(type-error :u8const))
2436	((tag :u8)
2437	(flags :u32)))
2438	(and tag object (:$ arm::tagmask))
2439	(cmp tag (:$ arm::tag-misc))
2440	(ldrbeq tag (:@ object (:$ arm::misc-subtag-offset)))
2441	(cmp tag (:$ arm::subtag-arrayH))
2442	(bne :bad-if-ne)
2443	(ldr tag (:@ object (:$ arm::arrayH.rank)))
2444	(cmp tag (:$ (ash 3 arm::fixnumshift)))
2445	(bne :bad-if-ne)
2446	(mov tag (:$ (:apply ash (:apply logand expected-flags #xff00) arm::fixnumshift)))
2447	(orr tag tag (:$ (:apply ash (:apply logand expected-flags #x00ff) arm::fixnumshift)))
2448	(ldr flags (:@ object (:$ arm::arrayH.flags)))
2449	(cmp tag flags)
2450	:bad-if-ne
2451	(uuo-error-reg-not-xtype (:? ne) object (:$ type-error)))
2452
2453
2454
2455
2456	(define-arm-vinsn sign-extend-halfword (((dest :imm))
2457	((src :imm)))
2458	(mov dest (:lsl src (:$ (- 16 arm::fixnumshift))))
2459	(mov dest (:asr dest (:$ (- 16 arm::fixnumshift)))))
2460
2461
2462
2463
2464	(define-arm-vinsn fixnum-add (((dest t))
2465	((x t)
2466	(y t)))
2467	(add dest x y))
2468
2469
2470	(define-arm-vinsn fixnum-add-overflow-ool (()
2471	((x :imm)
2472	(y :imm))
2473	())
2474	(adds arm::arg_z x y)
2475	(blvs .SPfix-overflow))
2476
2477	(define-arm-vinsn fixnum-add-overflow-inline (((dest :lisp))
2478	((x :imm)
2479	(y :imm))
2480	((unboxed :s32)
2481	(header :u32)))
2482	(adds dest x y)
2483	(bvc :done)
2484	(mov unboxed (:asr dest (:$ arm::fixnumshift)))
2485	(mov header (:$ arm::subtag-bignum))
2486	(orr header header (:$ (ash 1 arm::num-subtag-bits)))
2487	(eor unboxed unboxed (:$ #xc0000000))
2488	(sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc)))
2489	(ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
2490	(cmp allocptr dest)
2491	(uuo-alloc-trap (:? lo))
2492	(str header (:@ allocptr (:$ arm::misc-header-offset)))
2493	(mov dest allocptr)
2494	(bic allocptr allocptr (:$ arm::fulltagmask))
2495	(str unboxed (:@ dest (:$ arm::misc-data-offset)))
2496	:done)
2497
2498	(define-arm-vinsn fixnum-add-overflow-inline-skip (((dest :lisp))
2499	((x :imm)
2500	(y :imm)
2501	(target :label))
2502	((unboxed :s32)
2503	(header :u32)))
2504	(adds dest x y)
2505	(bvc target)
2506	(mov unboxed (:asr dest (:$ arm::fixnumshift)))
2507	(mov header (:$ arm::subtag-bignum))
2508	(orr header header (:$ (ash 1 arm::num-subtag-bits)))
2509	(eor unboxed unboxed (:$ #xc0000000))
2510	(sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc)))
2511	(ldr dest (:@ rcontext (:$ arm::tcr.save-allocptr)))
2512	(cmp allocptr dest)
2513	(uuo-alloc-trap (:? lo))
2514	(str header (:@ allocptr (:$ arm::misc-header-offset)))
2515	(mov dest allocptr)
2516	(bic allocptr allocptr (:$ arm::fulltagmask))
2517	(str unboxed (:@ dest (:$ arm::misc-data-offset)))
2518	(b target))
2519
2520
2521
2522
2523	;;; (setq dest (- x y))
2524	(define-arm-vinsn fixnum-sub (((dest t))
2525	((x t)
2526	(y t)))
2527	(sub dest x y))
2528
2529	(define-arm-vinsn fixnum-sub-from-constant (((dest :imm))
2530	((x :s16const)
2531	(y :imm)))
2532	(rsb dest y (:$ (:apply ash x arm::fixnumshift))))
2533
2534
2535
2536
2537	(define-arm-vinsn fixnum-sub-overflow-ool (()
2538	((x :imm)
2539	(y :imm)))
2540	(subs arm::arg_z x y)
2541	(blvs .SPfix-overflow))
2542
2543	(define-arm-vinsn fixnum-sub-overflow-inline (((dest :lisp))
2544	((x :imm)
2545	(y :imm))
2546	((cr0 (:crf 0))
2547	(unboxed :s32)
2548	(header :u32)))
2549	(subs dest x y)
2550	(bvc :done)
2551	(mov unboxed (:asr dest (:$ arm::fixnumshift)))
2552	(mov header (:$ arm::subtag-bignum))
2553	(orr header header (:$ (ash 1 arm::num-subtag-bits)))
2554	(eor unboxed unboxed (:$ #xc0000000))
2555	(sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc)))
2556	(ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
2557	(cmp allocptr dest)
2558	(uuo-alloc-trap (:? lo))
2559	(str header (:@ allocptr (:$ arm::misc-header-offset)))
2560	(mov dest allocptr)
2561	(bic allocptr allocptr (:$ arm::fulltagmask))
2562	(str unboxed (:@ dest (:$ arm::misc-data-offset)))
2563	:done)
2564
2565	(define-arm-vinsn fixnum-sub-overflow-inline-skip (((dest :lisp))
2566	((x :imm)
2567	(y :imm)
2568	(target :label))
2569	((unboxed :s32)
2570	(header :u32)))
2571	(subs dest x y)
2572	(bvc target)
2573	(mov unboxed (:asr dest (:$ arm::fixnumshift)))
2574	(mov header (:$ arm::subtag-bignum))
2575	(orr header header (:$ (ash 1 arm::num-subtag-bits)))
2576	(eor unboxed unboxed (:$ #xc0000000))
2577	(sub allocptr allocptr (:$ (- arm::dnode-size arm::fulltag-misc)))
2578	(ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
2579	(cmp allocptr dest)
2580	(uuo-alloc-trap (:? lo))
2581	(str header (:@ allocptr (:$ arm::misc-header-offset)))
2582	(mov dest allocptr)
2583	(bic allocptr allocptr (:$ arm::fulltagmask))
2584	(str unboxed (:@ dest (:$ arm::misc-data-offset)))
2585	(b target))
2586
2587	;;; This is, of course, also "subtract-immediate."
2588	(define-arm-vinsn add-immediate (((dest t))
2589	((src t)
2590	(imm :s32const)))
2591	(add dest src (:$ imm)))
2592
2593	(define-arm-vinsn multiply-fixnums (((dest :imm))
2594	((a :imm)
2595	(b :imm))
2596	((unboxed :s32)))
2597	(mov unboxed (:asr b (:$ arm::fixnumshift)))
2598	(mul dest a unboxed))
2599
2600
2601
2602	;;; Mask out the code field of a base character; the result
2603	;;; should be EXACTLY = to subtag-base-char
2604	(define-arm-vinsn mask-base-char (((dest :u32))
2605	((src :imm)))
2606	(and dest src (:$ arm::subtag-mask)))
2607
2608	;;; Set dest (of type :s32!) to 0 iff VAL is an istruct of type TYPE
2609	(define-arm-vinsn istruct-typep (((dest :s32))
2610	((val :lisp)
2611	(type :lisp))
2612	((temp :lisp)))
2613	(and dest val (:$ arm::tagmask))
2614	(cmp dest (:$ arm::tag-misc))
2615	(ldrbeq dest (:@ val (:$ arm::misc-subtag-offset)))
2616	(cmp dest (:$ arm::subtag-istruct))
2617	(movne dest (:$ -1))
2618	(ldreq temp (:@ val (:$ arm::misc-data-offset)))
2619	(subeq dest type temp))
2620
2621
2622	;; Boundp, fboundp stuff.
2623	(define-arm-vinsn (ref-symbol-value :call :subprim-call)
2624	(((val :lisp))
2625	((sym (:lisp (:ne val)))))
2626	(bl .SPspecrefcheck))
2627
2628	(define-arm-vinsn ref-symbol-value-inline (((dest :lisp))
2629	((src (:lisp (:ne dest))))
2630	((table :imm)
2631	(idx :imm)))
2632	(ldr idx (:@ src (:$ arm::symbol.binding-index)))
2633	(ldr table (:@ rcontext (:$ arm::tcr.tlb-limit)))
2634	(cmp idx table)
2635	(ldr table (:@ rcontext (:$ arm::tcr.tlb-pointer)))
2636	(movhs idx (:$ 0))
2637	(ldr dest (:@ table idx))
2638	(cmp dest (:$ arm::subtag-no-thread-local-binding))
2639	(ldreq dest (:@ src (:$ arm::symbol.vcell)))
2640	(cmp dest (:$ arm::unbound-marker))
2641	(uuo-error-unbound (:? eq) src))
2642
2643	(define-arm-vinsn (%ref-symbol-value :call :subprim-call)
2644	(((val :lisp))
2645	((sym (:lisp (:ne val)))))
2646	(bl .SPspecref))
2647
2648	(define-arm-vinsn %ref-symbol-value-inline (((dest :lisp))
2649	((src (:lisp (:ne dest))))
2650	((table :imm)
2651	(idx :imm)))
2652	(ldr idx (:@ src (:$ arm::symbol.binding-index)))
2653	(ldr table (:@ rcontext (:$ arm::tcr.tlb-limit)))
2654	(cmp idx table)
2655	(ldr table (:@ rcontext (:$ arm::tcr.tlb-pointer)))
2656	(movhs idx (:$ 0))
2657	(ldr dest (:@ table idx))
2658	(cmp dest (:$ arm::subtag-no-thread-local-binding))
2659	(ldreq dest (:@ src (:$ arm::symbol.vcell))))
2660
2661	(define-arm-vinsn (setq-special :call :subprim-call)
2662	(()
2663	((sym :lisp)
2664	(val :lisp)))
2665	(bl .SPspecset))
2666
2667
2668	(define-arm-vinsn symbol-function (((val :lisp))
2669	((sym (:lisp (:ne val))))
2670	((crf :crf)
2671	(tag :u32)))
2672	(ldr val (:@ sym (:$ arm::symbol.fcell)))
2673	(and tag val (:$ arm::tagmask))
2674	(cmp tag (:$ arm::tag-misc))
2675	(ldrbeq tag (:@ val (:$ arm::misc-subtag-offset)))
2676	(cmp tag (:$ arm::subtag-function))
2677	(uuo-error-udf (:? ne) sym))
2678
2679	(define-arm-vinsn (temp-push-unboxed-word :push :word :sp)
2680	(()
2681	((w :u32))
2682	((header :u32)))
2683	(mov header (:$ arm::subtag-u32-vector))
2684	(orr header header (:$ (ash 1 arm::num-subtag-bits)))
2685	(str header (:@! sp (:$ (- arm::dnode-size))))
2686	(str w (:@ sp (:$ 4))))
2687
2688	(define-arm-vinsn (temp-pop-unboxed-word :pop :word :sp)
2689	(((w :u32))
2690	())
2691	(ldr w (:@ sp (:$ 4)))
2692	(add sp sp (:$ arm::dnode-size)))
2693
2694	(define-arm-vinsn (temp-push-double-float :push :doubleword :sp)
2695	(()
2696	((d :double-float))
2697	((header :u32)))
2698	(mov header (:$ arm::subtag-double-float))
2699	(orr header header (:$ (ash arm::double-float.element-count arm::num-subtag-bits)))
2700	(str header (:@! sp (:$ (- (* 2 arm::dnode-size)))))
2701	(fstd d (:@ sp (:$ 8))))
2702
2703	(define-arm-vinsn (temp-pop-double-float :pop :doubleword :sp)
2704	(()
2705	((d :double-float)))
2706	(fldd d (:@ sp (:$ 8)))
2707	(add sp sp (:$ (* 2 arm::dnode-size))))
2708
2709
2710	(define-arm-vinsn (temp-push-single-float :push :word :tsp)
2711	(()
2712	((s :single-float))
2713	((header :u32)))
2714	(mov header (:$ arm::subtag-single-float))
2715	(orr header header (:$ (ash arm::single-float.element-count arm::num-subtag-bits)))
2716	(str header (:@! sp (:$ (- arm::dnode-size))))
2717	(fsts s (:@ sp (:$ 4))))
2718
2719
2720	(define-arm-vinsn (temp-pop-single-float :pop :word :sp)
2721	(()
2722	((s :single-float)))
2723	(flds s (:@ sp (:$ 4)))
2724	(add sp sp (:$ arm::dnode-size)))
2725
2726
2727
2728	(define-arm-vinsn %current-frame-ptr (((dest :imm))
2729	())
2730	(mov dest arm::sp))
2731
2732	(define-arm-vinsn %current-tcr (((dest :imm))
2733	())
2734	(mov dest rcontext))
2735
2736	(define-arm-vinsn (dpayback :call :subprim-call) (()
2737	((n :s16const))
2738	((temp (:u32 #.arm::imm0))))
2739	((:pred > n 1)
2740	(mov temp (:$ n))
2741	(bl .SPunbind-n))
2742	((:pred = n 1)
2743	(bl .SPunbind)))
2744
2745	(define-arm-vinsn zero-double-float-register (((dest :double-float))
2746	()
2747	((temp :imm)))
2748	(mov temp (:$ 0))
2749	(fmsr dest temp))
2750
2751	(define-arm-vinsn zero-single-float-register (((dest :single-float))
2752	()
2753	((temp :imm)))
2754	(mov temp (:$ 0))
2755	(fmdrr dest temp temp))
2756
2757	(define-arm-vinsn load-double-float-constant (((dest :double-float))
2758	((high :u32)
2759	(low :u32)))
2760	(fmdrr dest low high))
2761
2762	(define-arm-vinsn load-single-float-constant (((dest :single-float))
2763	((src t)))
2764	(fmsr dest src))
2765
2766	(define-arm-vinsn load-indexed-node (((node :lisp))
2767	((base :lisp)
2768	(offset :s16const)))
2769	(ldr node (:@ base (:$ offset))))
2770
2771	(define-arm-vinsn check-exact-nargs (()
2772	((n :u16const)))
2773	(cmp nargs (:$ (:apply ash n 2)))
2774	(uuo-error-wrong-nargs (:? ne)))
2775
2776	(define-arm-vinsn check-min-nargs (()
2777	((min :u16const)))
2778	(cmp nargs (:$ (:apply ash min 2)))
2779	(uuo-error-wrong-nargs (:? lo)))
2780
2781
2782	(define-arm-vinsn check-max-nargs (()
2783	((max :u16const)))
2784	(cmp nargs (:$ (:apply ash max 2)))
2785	(uuo-error-wrong-nargs (:? hi)))
2786
2787	;;; Save context and establish FN. The current VSP is the the
2788	;;; same as the caller's, e.g., no arguments were vpushed.
2789	(define-arm-vinsn save-lisp-context-vsp (()
2790	()
2791	((imm :u32)))
2792	(mov imm (:$ arm::lisp-frame-marker))
2793	(stmdb (:! sp) (imm vsp fn lr))
2794	(mov fn nfn))
2795
2796
2797
2798	(define-arm-vinsn save-lisp-context-offset (()
2799	((nbytes-vpushed :u16const))
2800	((imm (:u32 #.arm::imm1))))
2801	(add imm vsp (:$ nbytes-vpushed))
2802	(mov imm0 (:$ arm::lisp-frame-marker))
2803	(stmdb (:! sp) (imm0 imm fn lr))
2804	(mov fn nfn))
2805
2806	(define-arm-vinsn save-lisp-context-variable (()
2807	()
2808	((imm (:u32 #.arm::imm1))))
2809	(subs imm nargs (:$ (ash $numarmargregs arm::word-shift)))
2810	(movmi imm (:$ 0))
2811	(add imm imm vsp)
2812	(mov imm0 (:$ arm::lisp-frame-marker))
2813	(stmdb (:! sp) (imm0 imm fn lr))
2814	(mov fn nfn))
2815
2816
2817
2818
2819	(define-arm-vinsn save-cleanup-context (()
2820	())
2821	(mov temp2 (:$ 0))
2822	(mov imm0 (:$ arm::lisp-frame-marker))
2823	(stmdb (:! sp) (imm0 vsp fn lr))
2824	(str temp2 (:@ sp (:$ arm::lisp-frame.savefn))))
2825
2826
2827
2828	;; Vpush the argument registers. We got at least "min-fixed" args;
2829	;; that knowledge may help us generate better code.
2830	(define-arm-vinsn (save-lexpr-argregs :call :subprim-call)
2831	(()
2832	((min-fixed :u16const))
2833	((entry-vsp (:u32 #.arm::imm1))
2834	(arg-temp (:u32 #.arm::imm0))
2835	(other-temp :imm)))
2836	((:pred >= min-fixed $numarmargregs)
2837	(stm (:! vsp) (arg_z arg_y arg_x)))
2838	((:pred = min-fixed 2) ; at least 2 args
2839	(cmp nargs (:$ (ash 2 arm::word-shift)))
2840	(strne arg_x (:@! vsp (:$ -4)))
2841	(stm (:! vsp) (arg_z arg_y)))
2842	((:pred = min-fixed 1) ; at least one arg
2843	(cmp nargs (:$ (ash 2 arm::word-shift)))
2844	(strlo arg_z (:@! vsp (:$ (- arm::node-size))))
2845	(stmeq (:! vsp) (arg_z arg_y))
2846	(stmhi (:! vsp) (arg_z arg_y arg_x)))
2847	((:pred = min-fixed 0)
2848	(cmp nargs (:$ 0))
2849	(beq :done)
2850	(cmp nargs (:$ (ash 2 arm::word-shift)))
2851	(strlo arg_z (:@! vsp (:$ (- arm::node-size))))
2852	(stmeq (:! vsp) (arg_z arg_y))
2853	(stmhi (:! vsp) (arg_z arg_y arg_x))
2854	:done
2855	)
2856	((:pred = min-fixed 0)
2857	(str nargs (:@! vsp (:$ -4))))
2858	((:not (:pred = min-fixed 0))
2859	(sub arg-temp nargs (:$ (:apply ash min-fixed arm::word-shift)))
2860	(str arg-temp (:@! vsp (:$ -4))))
2861	(add entry-vsp vsp nargs)
2862	(mov other-temp (:$ (- arm::nil-value arm::fulltag-nil)))
2863	(ldr other-temp (:@ other-temp (:$ (arm::%kernel-global 'arm::ret1valaddr))))
2864	(add entry-vsp entry-vsp (:$ 4))
2865	(cmp other-temp lr)
2866	(mov arg-temp (:$ arm::lisp-frame-marker))
2867	(stmdb (:! vsp) (arg-temp entry-vsp fn lr))
2868	(mov fn (:$ 0))
2869	(moveq lr (:$ (- arm::nil-value arm::fulltag-nil)))
2870	(ldreq lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return))))
2871	(stmdbeq (:! vsp) (arg-temp entry-vsp fn lr))
2872	(moveq lr other-temp)
2873	(movne lr (:$ (- arm::nil-value arm::fulltag-nil)))
2874	(ldrne lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return1v))))
2875	)
2876
2877
2878
2879	(define-arm-vinsn (jump-return-pc :jumpLR)
2880	(()
2881	())
2882	(bx lr))
2883
2884	(define-arm-vinsn (restore-full-lisp-context :lispcontext :pop :csp :lrRestore)
2885	(()
2886	())
2887	(ldmia (:! sp) (imm0 vsp fn lr)))
2888
2889
2890
2891
2892
2893	(define-arm-vinsn (popj :lispcontext :pop :csp :lrRestore :jumpLR)
2894	(()
2895	())
2896	(ldmia (:! sp) (imm0 vsp fn pc)))
2897
2898	;;; Exiting from an UNWIND-PROTECT cleanup is similar to
2899	;;; (and a little simpler than) returning from a function.
2900	(define-arm-vinsn restore-cleanup-context (()
2901	())
2902	(ldr lr (:@ sp (:$ arm::lisp-frame.savelr)))
2903	(add sp sp (:$ arm::lisp-frame.size)))
2904
2905
2906
2907	(define-arm-vinsn default-1-arg (()
2908	((min :u16const)))
2909	(cmp nargs (:$ (:apply ash min 2)))
2910	(bne :done)
2911	((:pred >= min 3)
2912	(str arg_x (:@! vsp (:$ (- arm::node-size)))))
2913	((:pred >= min 2)
2914	(mov arg_x arg_y))
2915	((:pred >= min 1)
2916	(mov arg_y arg_z))
2917	(mov arm::arg_z (:$ arm::nil-value))
2918	:done)
2919
2920	(define-arm-vinsn default-2-args (()
2921	((min :u16const)))
2922	(cmp nargs (:$ (:apply ash (:apply 1+ min) 2)))
2923	(bgt :done)
2924	(beq :one)
2925	;; We got "min" args; arg_y & arg_z default to nil
2926	((:pred >= min 3)
2927	(str arg_x (:@! vsp (:$ (- arm::node-size)))))
2928	((:pred >= min 2)
2929	(str arg_y (:@! vsp (:$ (- arm::node-size)))))
2930	((:pred >= min 1)
2931	(mov arg_x (:$ arm::nil-value)))
2932	(mov arg_y (:$ arm::nil-value))
2933	(b :last)
2934	:one
2935	;; We got min+1 args: arg_y was supplied, arg_z defaults to nil.
2936	((:pred >= min 2)
2937	(str arg_x (:@! vsp (:$ (- arm::node-size)))))
2938	((:pred >= min 1)
2939	(mov arg_x arg_y))
2940	(mov arm::arg_y arm::arg_z)
2941	:last
2942	(mov arg_z (:$ arm::nil-value))
2943	:done)
2944
2945	(define-arm-vinsn default-3-args (()
2946	((min :u16const)))
2947	(cmp nargs (:$ (:apply ash min 2)))
2948	(beq :none)
2949	(cmp nargs (:$ (:apply ash (:apply + 2 min) 2)))
2950
2951	(bgt :done)
2952	(beq :two)
2953	;; The first (of three) &optional args was supplied.
2954	((:pred >= min 2)
2955	(str arg_x (:@! vsp (:$ (- arm::node-size)))))
2956	((:pred >= min 1)
2957	(str arg_y (:@! vsp (:$ (- arm::node-size)))))
2958	(mov arg_x arg_z)
2959	(b :last-2)
2960	:two
2961	;; The first two (of three) &optional args were supplied.
2962	((:pred >= min 1)
2963	(str arg_x (:@! vsp (:$ (- arm::node-size)))))
2964	(mov arg_x arg_y)
2965	(mov arg_y arg_z)
2966	(b :last-1)
2967	;; None of the three &optional args was provided.
2968	:none
2969	((:pred >= min 3)
2970	(str arg_x (:@! vsp (:$ (- arm::node-size)))))
2971	((:pred >= min 2)
2972	(str arg_y (:@! vsp (:$ (- arm::node-size)))))
2973	((:pred >= min 1)
2974	(str arg_z (:@! vsp (:$ (- arm::node-size)))))
2975	(mov arg_x (:$ arm::nil-value))
2976	:last-2
2977	(mov arg_y (:$ arm::nil-value))
2978	:last-1
2979	(mov arg_z (:$ arm::nil-value))
2980	:done)
2981
2982
2983
2984	;;; "n" is the sum of the number of required args +
2985	;;; the number of &optionals.
2986	(define-arm-vinsn (default-optionals :call :subprim-call) (()
2987	((n :u16const)))
2988	(mov imm0 (:$ (:apply ash n 2)))
2989	(bl .SPdefault-optional-args))
2990
2991	;;; fname contains a known symbol
2992	(define-arm-vinsn (call-known-symbol :call) (((result (:lisp arm::arg_z)))
2993	())
2994	(ldr nfn (:@ fname (:$ arm::symbol.fcell)))
2995	(ldr lr (:@ nfn (:$ arm::function.entrypoint)))
2996	(blx lr))
2997
2998	(define-arm-vinsn (jump-known-symbol :jumplr) (()
2999	())
3000	(ldr nfn (:@ fname (:$ arm::symbol.fcell)))
3001	(ldr pc (:@ nfn (:$ arm::function.entrypoint))))
3002
3003	(define-arm-vinsn (call-known-function :call) (()
3004	())
3005	(ldr lr (:@ nfn (:$ arm::function.entrypoint)))
3006	(blx lr))
3007
3008	(define-arm-vinsn (jump-known-function :jumplr) (()
3009	())
3010	(ldr pc (:@ nfn (:$ arm::function.entrypoint))))
3011
3012	(define-arm-vinsn %schar8 (((char :imm))
3013	((str :lisp)
3014	(idx :imm))
3015	((imm :u32)))
3016	(mov imm (:lsr idx (:$ arm::fixnumshift)))
3017	(add imm imm (:$ arm::misc-data-offset))
3018	(ldrb imm (:@ str imm))
3019	(mov imm (:lsl imm (:$ arm::charcode-shift)))
3020	(orr char imm (:$ arm::subtag-character)))
3021
3022	(define-arm-vinsn %schar32 (((char :imm))
3023	((str :lisp)
3024	(idx :imm))
3025	((imm :u32)))
3026	(add imm idx (:$ arm::misc-data-offset))
3027	(ldr imm (:@ str imm))
3028	(mov imm (:lsl imm (:$ arm::charcode-shift)))
3029	(orr char imm (:$ arm::subtag-character)))
3030
3031
3032	(define-arm-vinsn %set-schar8 (()
3033	((str :lisp)
3034	(idx :imm)
3035	(char :imm))
3036	((imm :u32)
3037	(imm1 :u32)))
3038	(mov imm (:lsr idx (:$ arm::fixnumshift)))
3039	(add imm imm (:$ arm::misc-data-offset))
3040	(mov imm1 (:lsr char (:$ arm::charcode-shift)))
3041	(strb imm1 (:@ str imm)))
3042
3043	(define-arm-vinsn %set-schar32 (()
3044	((str :lisp)
3045	(idx :imm)
3046	(char :imm))
3047	((imm :u32)
3048	(imm1 :u32)))
3049	(add imm idx (:$ arm::misc-data-offset))
3050	(mov imm1 (:lsr char (:$ arm::charcode-shift)))
3051	(str imm1 (:@ str imm)))
3052
3053	(define-arm-vinsn %set-scharcode8 (()
3054	((str :lisp)
3055	(idx :imm)
3056	(code :imm))
3057	((imm :u32)
3058	(imm1 :u32)))
3059	(mov imm (:lsr idx (:$ arm::fixnumshift)))
3060	(add imm imm (:$ arm::misc-data-offset))
3061	(mov imm1 (:lsr code (:$ arm::fixnumshift)))
3062	(strb imm1 (:@ str imm)))
3063
3064
3065	(define-arm-vinsn %set-scharcode32 (()
3066	((str :lisp)
3067	(idx :imm)
3068	(code :imm))
3069	((imm :u32)
3070	(imm1 :u32)))
3071	(add imm idx (:$ arm::misc-data-offset))
3072	(mov imm1 (:lsr code (:$ arm::fixnumshift)))
3073	(str imm1 (:@ str imm)))
3074
3075	(define-arm-vinsn %scharcode8 (((code :imm))
3076	((str :lisp)
3077	(idx :imm))
3078	((imm :u32)))
3079	(mov imm (:lsr idx (:$ arm::fixnumshift)))
3080	(add imm imm (:$ arm::misc-data-offset))
3081	(ldrb imm (:@ str imm))
3082	(mov code (:lsl imm (:$ arm::fixnumshift))))
3083
3084	(define-arm-vinsn %scharcode32 (((code :imm))
3085	((str :lisp)
3086	(idx :imm))
3087	((imm :u32)))
3088	(add imm idx (:$ arm::misc-data-offset))
3089	(ldr imm (:@ str imm))
3090	(mov code (:lsl imm (:$ arm::fixnumshift))))
3091
3092	;;; Clobbers LR
3093	(define-arm-vinsn %debug-trap (()
3094	())
3095	(uuo-debug-trap))
3096
3097
3098	(define-arm-vinsn eep.address (((dest t))
3099	((src (:lisp (:ne dest )))))
3100	(ldr dest (:@ src (:$ (+ (ash 1 2) arm::misc-data-offset))))
3101	(cmp dest (:$ arm::nil-value))
3102	(uuo-eep-unresolved (:? eq) src dest))
3103
3104	(define-arm-vinsn %natural+ (((dest :u32))
3105	((x :u32) (y :u32)))
3106	(add dest x y))
3107
3108	(define-arm-vinsn %natural+-c (((dest :u32))
3109	((x :u32) (y :u16const)))
3110	(add dest x (:$ y)))
3111
3112	(define-arm-vinsn %natural- (((dest :u32))
3113	((x :u32) (y :u32)))
3114	(sub dest x y))
3115
3116	(define-arm-vinsn %natural--c (((dest :u32))
3117	((x :u32) (y :u16const)))
3118	(sub dest x (:$ y)))
3119
3120	(define-arm-vinsn %natural-logior (((dest :u32))
3121	((x :u32) (y :u32)))
3122	(orr dest x y))
3123
3124	(define-arm-vinsn %natural-logior-c (((dest :u32))
3125	((x :u32) (c :u32const)))
3126	(orr dest x (:$ c)))
3127
3128	(define-arm-vinsn %natural-logxor (((dest :u32))
3129	((x :u32) (y :u32)))
3130	(eor dest x y))
3131
3132	(define-arm-vinsn %natural-logxor-c (((dest :u32))
3133	((x :u32) (c :u32const)))
3134	(eor dest x (:$ c)))
3135
3136	(define-arm-vinsn %natural-logand (((dest :u32))
3137	((x :u32) (y :u32)))
3138	(and dest x y))
3139
3140	(define-arm-vinsn %natural-logand-c (((dest :u32))
3141	((x :u32) (c :u16const))
3142	)
3143	(and dest x (:$ c)))
3144
3145	(define-arm-vinsn %ilogbitp-constant-bit (((dest :crf))
3146	((fixnum :imm)
3147	(bitnum :u8const)))
3148	(tst fixnum (:$ (:apply ash 1 (:apply + bitnum arm::fixnumshift)))))
3149
3150	(define-arm-vinsn %ilogbitp-variable-bit (((dest :crf))
3151	((fixnum :imm)
3152	(bitnum :u8))
3153	((mask :imm)
3154	(unboxed :u8)))
3155	(mov unboxed (:asr bitnum (:$ arm::fixnumshift)))
3156	(mov mask (:$ arm::fixnumone))
3157	(tst fixnum (:lsl mask unboxed)))
3158
3159
3160
3161
3162
3163	(define-arm-vinsn disable-interrupts (((dest :lisp))
3164	()
3165	((temp :imm)
3166	(temp2 :imm)))
3167	(ldr temp2 (:@ rcontext (:$ arm::tcr.tlb-pointer)))
3168	(mov temp (:$ -4))
3169	(ldr dest (:@ temp2 (:$ arm::interrupt-level-binding-index)))
3170	(str temp (:@ temp2 (:$ arm::interrupt-level-binding-index))))
3171
3172	(define-arm-vinsn load-character-constant (((dest :lisp))
3173	((code :u32const)))
3174	(mov dest (:$ arm::subtag-character))
3175	((:pred logtest #xff code)
3176	(orr dest dest (:$ (:apply ash (:apply logand code #xff) 8))))
3177	((:pred logtest #xff00 code)
3178	(orr dest dest (:$ (:apply ash (:apply ldb (byte 8 8) code) 16))))
3179	((:pred logtest #xff000 code)
3180	(orr dest dest (:$ (:apply ash (:apply ldb (byte 8 16) code) 24)))))
3181
3182
3183	(define-arm-vinsn %symbol->symptr (((dest :lisp))
3184	((src :lisp))
3185	((tag :u8)))
3186	(cmp src (:$ arm::nil-value))
3187	(and tag src (:$ arm::tagmask))
3188	(beq :nilsym)
3189	(cmp tag (:$ arm::tag-misc))
3190	(ldrbeq tag (:@ src (:$ arm::misc-subtag-offset)))
3191	(cmp tag (:$ arm::subtag-symbol))
3192	(uuo-error-reg-not-xtype (:? ne) src (:$ arm::subtag-symbol))
3193	((:not (:pred =
3194	(:apply %hard-regspec-value dest)
3195	(:apply %hard-regspec-value src)))
3196	(mov dest src))
3197	(b :done)
3198	:nilsym
3199	(add dest src (:$ arm::nilsym-offset))
3200	:done)
3201
3202	;;; Subprim calls. Done this way for the benefit of VINSN-OPTIMIZE.
3203	(defmacro define-arm-subprim-call-vinsn ((name &rest other-attrs) spno)
3204	`(define-arm-vinsn (,name :call :subprim-call ,@other-attrs) (() ())
3205	(bl ,spno)))
3206
3207	(defmacro define-arm-subprim-jump-vinsn ((name &rest other-attrs) spno)
3208	`(define-arm-vinsn (,name :jumpLR ,@other-attrs) (() ())
3209	(ba ,spno)))
3210
3211
3212	(define-arm-subprim-call-vinsn (save-values) .SPsave-values)
3213
3214	(define-arm-subprim-call-vinsn (recover-values) .SPrecover-values)
3215
3216	(define-arm-subprim-call-vinsn (add-values) .SPadd-values)
3217
3218
3219	(define-arm-subprim-call-vinsn (pass-multiple-values) .SPmvpass)
3220
3221	(define-arm-subprim-call-vinsn (pass-multiple-values-symbol) .SPmvpasssym)
3222
3223	(define-arm-subprim-jump-vinsn (tail-call-sym-gen) .SPtcallsymgen)
3224
3225	(define-arm-subprim-jump-vinsn (tail-call-fn-gen) .SPtcallnfngen)
3226
3227	(define-arm-subprim-jump-vinsn (tail-call-sym-slide) .SPtcallsymslide)
3228
3229	(define-arm-subprim-jump-vinsn (tail-call-fn-slide) .SPtcallnfnslide)
3230
3231
3232	(define-arm-subprim-call-vinsn (funcall) .SPfuncall)
3233
3234	(define-arm-subprim-jump-vinsn (tail-funcall-gen) .SPtfuncallgen)
3235
3236	(define-arm-subprim-jump-vinsn (tail-funcall-slide) .SPtfuncallslide)
3237
3238	(define-arm-subprim-jump-vinsn (tail-funcall-vsp) .SPtfuncallvsp)
3239
3240	(define-arm-subprim-call-vinsn (spread-lexpr) .SPspread-lexprz)
3241
3242	(define-arm-subprim-call-vinsn (spread-list) .SPspreadargz)
3243
3244
3245	(define-arm-subprim-call-vinsn (getu32) .SPgetu32)
3246
3247	(define-arm-subprim-call-vinsn (gets32) .SPgets32)
3248
3249
3250	(define-arm-subprim-call-vinsn (stack-cons-list) .SPstkconslist)
3251
3252	(define-arm-subprim-call-vinsn (list) .SPconslist)
3253
3254	(define-arm-subprim-call-vinsn (stack-cons-list*) .SPstkconslist-star)
3255
3256	(define-arm-subprim-call-vinsn (list*) .SPconslist-star)
3257
3258	(define-arm-subprim-call-vinsn (make-stack-block) .SPmakestackblock)
3259
3260	(define-arm-subprim-call-vinsn (make-stack-block0) .Spmakestackblock0)
3261
3262	(define-arm-subprim-call-vinsn (make-stack-list) .Spmakestacklist)
3263
3264	(define-arm-subprim-call-vinsn (make-stack-vector) .SPmkstackv)
3265
3266	(define-arm-subprim-call-vinsn (make-stack-gvector) .SPstkgvector)
3267
3268	(define-arm-subprim-call-vinsn (stack-misc-alloc) .SPstack-misc-alloc)
3269
3270	(define-arm-subprim-call-vinsn (stack-misc-alloc-init) .SPstack-misc-alloc-init)
3271
3272	(define-arm-subprim-call-vinsn (bind-nil) .SPbind-nil)
3273
3274	(define-arm-subprim-call-vinsn (bind-self) .SPbind-self)
3275
3276	(define-arm-subprim-call-vinsn (bind-self-boundp-check) .SPbind-self-boundp-check)
3277
3278	(define-arm-subprim-call-vinsn (bind) .SPbind)
3279
3280	(define-arm-subprim-jump-vinsn (nvalret :jumpLR) .SPnvalret)
3281
3282	(define-arm-subprim-call-vinsn (nthrowvalues) .SPnthrowvalues)
3283
3284	(define-arm-subprim-call-vinsn (nthrow1value) .SPnthrow1value)
3285
3286	(define-arm-subprim-call-vinsn (slide-values) .SPmvslide)
3287
3288
3289	(define-arm-subprim-call-vinsn (debind) .SPdebind)
3290
3291
3292	(define-arm-subprim-call-vinsn (keyword-bind) .SPkeyword-bind)
3293
3294	(define-arm-subprim-call-vinsn (stack-rest-arg) .SPstack-rest-arg)
3295
3296	(define-arm-subprim-call-vinsn (req-stack-rest-arg) .SPreq-stack-rest-arg)
3297
3298	(define-arm-subprim-call-vinsn (stack-cons-rest-arg) .SPstack-cons-rest-arg)
3299
3300	(define-arm-subprim-call-vinsn (heap-rest-arg) .SPheap-rest-arg)
3301
3302	(define-arm-subprim-call-vinsn (req-heap-rest-arg) .SPreq-heap-rest-arg)
3303
3304	(define-arm-subprim-call-vinsn (heap-cons-rest-arg) .SPheap-cons-rest-arg)
3305
3306	(define-arm-subprim-call-vinsn (opt-supplied-p) .SPopt-supplied-p)
3307
3308	(define-arm-subprim-call-vinsn (gvector) .SPgvector)
3309
3310	(define-arm-subprim-call-vinsn (discard-temp-frame) .SPdiscard_stack_object)
3311
3312	(define-arm-vinsn (nth-value :call :subprim-call) (((result :lisp))
3313	())
3314	(bl .SPnthvalue))
3315
3316	(define-arm-subprim-call-vinsn (fitvals) .SPfitvals)
3317
3318	(define-arm-subprim-call-vinsn (misc-alloc) .SPmisc-alloc)
3319
3320	(define-arm-subprim-call-vinsn (misc-alloc-init) .SPmisc-alloc-init)
3321
3322	(define-arm-subprim-call-vinsn (integer-sign) .SPinteger-sign)
3323
3324	;;; Even though it's implemented by calling a subprim, THROW is really
3325	;;; a JUMP (to a possibly unknown destination). If the destination's
3326	;;; really known, it should probably be inlined (stack-cleanup, value
3327	;;; transfer & jump ...)
3328	(define-arm-vinsn (throw :jump-unknown) (()
3329	())
3330	(bl .SPthrow))
3331
3332	(define-arm-subprim-call-vinsn (mkcatchmv) .SPmkcatchmv)
3333
3334	(define-arm-subprim-call-vinsn (mkcatch1v) .SPmkcatch1v)
3335
3336	(define-arm-subprim-call-vinsn (setqsym) .SPsetqsym)
3337
3338	(define-arm-subprim-call-vinsn (ksignalerr) .SPksignalerr)
3339
3340	(define-arm-subprim-call-vinsn (subtag-misc-ref) .SPsubtag-misc-ref)
3341
3342	(define-arm-subprim-call-vinsn (subtag-misc-set) .SPsubtag-misc-set)
3343
3344	(define-arm-subprim-call-vinsn (mkunwind) .SPmkunwind)
3345	(define-arm-subprim-call-vinsn (nmkunwind) .SPmkunwind)
3346
3347
3348	(define-arm-subprim-call-vinsn (progvsave) .SPprogvsave)
3349
3350	(define-arm-subprim-jump-vinsn (progvrestore) .SPprogvrestore)
3351
3352
3353	(define-arm-subprim-call-vinsn (misc-ref) .SPmisc-ref)
3354
3355	(define-arm-subprim-call-vinsn (misc-set) .SPmisc-set)
3356
3357	(define-arm-subprim-call-vinsn (gets64) .SPgets64)
3358
3359	(define-arm-subprim-call-vinsn (getu64) .SPgetu64)
3360
3361	(define-arm-subprim-call-vinsn (makeu64) .SPmakeu64)
3362
3363	(define-arm-subprim-call-vinsn (makes64) .SPmakes64)
3364
3365
3366
3367
3368
3369
3370
3371	(define-arm-subprim-call-vinsn (bind-interrupt-level-0) .SPbind-interrupt-level-0)
3372
3373	#+notyet
3374	(define-arm-vinsn bind-interrupt-level-0-inline (()
3375	()
3376	((tlb :imm)
3377	(value :imm)
3378	(link :imm)
3379	(temp :imm)))
3380	(ldr tlb (:@ rcontext (:$ arm::tcr.tlb-pointer)))
3381	(ldr value (:@ tlb (:$ arm::interrupt-level-binding-index)))
3382	(ldr link (:@ rcontext (:$ arm::tcr.db-link)))
3383	(cmpwi value 0)
3384	(li temp arm::interrupt-level-binding-index)
3385	(stwu value -4 vsp)
3386	(stwu temp -4 vsp)
3387	(stwu link -4 vsp)
3388	(str arm::rzero (:@ tlb (:$ arm::interrupt-level-binding-index)))
3389	(str vsp (:@ rcontext (:$ arm::tcr.db-link)))
3390	(beq+ :done)
3391	(mr nargs value)
3392	(bgt :do-trap)
3393	(ldr nargs (:@ rcontext (:$ arm::tcr.interrupt-pending)))
3394	:do-trap
3395	(twgti nargs 0)
3396	:done)
3397
3398
3399
3400	(define-arm-subprim-call-vinsn (bind-interrupt-level-m1) .SPbind-interrupt-level-m1)
3401
3402	(define-arm-vinsn bind-interrupt-level-m1-inline (()
3403	()
3404	((tlb :imm)
3405	(oldvalue :imm)
3406	(link :imm)
3407	(newvalue :imm)
3408	(idx :imm)))
3409	(mov newvalue (:$ (ash -1 arm::fixnumshift)))
3410	(mov idx (:$ arm::interrupt-level-binding-index))
3411	(ldr tlb (:@ rcontext (:$ arm::tcr.tlb-pointer)))
3412	(ldr oldvalue (:@ tlb (:$ arm::interrupt-level-binding-index)))
3413	(ldr link (:@ rcontext (:$ arm::tcr.db-link)))
3414	(str oldvalue (:@! vsp (:$ (- arm::node-size))))
3415	(str idx (:@! vsp (:$ (- arm::node-size))))
3416	(str link (:@! vsp (:$ (- arm::node-size))))
3417	(str newvalue (:@ tlb (:$ arm::interrupt-level-binding-index)))
3418	(str vsp (:@ rcontext (:$ arm::tcr.db-link))))
3419
3420	(define-arm-subprim-call-vinsn (bind-interrupt-level) .SPbind-interrupt-level)
3421
3422	(define-arm-subprim-call-vinsn (unbind-interrupt-level) .SPunbind-interrupt-level)
3423
3424	(define-arm-subprim-call-vinsn (eabi-ff-call) .SPeabi-ff-call)
3425
3426	(define-arm-vinsn unbind-interrupt-level-inline (()
3427	()
3428	((tlb :imm)
3429	(link :imm)
3430	(saved-value :imm)
3431	(restored-value :imm)))
3432	(ldr tlb (:@ rcontext (:$ arm::tcr.tlb-pointer)))
3433	(ldr saved-value (:@ tlb (:$ arm::interrupt-level-binding-index)))
3434	(ldr link (:@ rcontext (:$ arm::tcr.db-link)))
3435	(ldr restored-value (:@ link (:$ 8)))
3436	(ldr link (:@ link (:$ 0)))
3437	(cmp restored-value (:$ 0))
3438	(str restored-value (:@ tlb (:$ arm::interrupt-level-binding-index)))
3439	(str link (:@ rcontext (:$ arm::tcr.db-link)))
3440	(blt :done)
3441	(cmp saved-value (:$ 0))
3442	(bge :done)
3443	(ldr link (:@ rcontext (:$ arm::tcr.interrupt-pending)))
3444	(cmp link (:$ 0))
3445	(uuo-interrupt-now (:? ne))
3446	:done)
3447
3448
3449
3450	(define-arm-vinsn branch-unless-arg-fixnum (()
3451	((arg :lisp)
3452	(lab :label))
3453	())
3454	(tst arg (:$ arm::fixnummask))
3455	(bne lab))
3456
3457
3458
3459
3460	(define-arm-vinsn branch-unless-both-args-fixnums (()
3461	((arg0 :lisp)
3462	(arg1 :lisp)
3463	(lab :label))
3464	((tag :u8)))
3465	(orr tag arg0 arg1)
3466	(tst tag (:$ arm::fixnummask))
3467	(bne lab))
3468
3469	;;; In case arm::arm-opcodes was changed since this file was compiled.
3470	#+maybe-never
3471	(queue-fixup
3472	(fixup-vinsn-templates arm-vinsn-templates arm::arm-opcode-numbers))
3473
3474	(provide "ARM-VINSNS")
3475

Note: See TracBrowser for help on using the repository browser.

Download in other formats: