source: trunk/source/compiler/ARM/arm-asm.lisp @ 15158

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

Define another 3-register-argument UUO ('uuo_error_array_axis_bounds');
use it to report array bounds errors for multidimensional array access
(incorporating the axis/dimension in the UUO and therefore the error
message.)

File size: 84.2 KB
Line 
1;;-*- Mode: Lisp; Package: (ARM :use CL) -*-
2;;;
3;;;   Copyright (C) 2005-2009 Clozure Associates and contributors.
4;;;   This file is part of Clozure CL.
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License   known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict  the preamble takes precedence.
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(eval-when (:compile-toplevel :load-toplevel :execute)
18(require "ARM-ARCH")
19)
20
21(in-package "ARM")
22
23(defparameter *arm-condition-names* '(("eq" . 0) ("ne" . 1)
24                                      ("hs" . 2) ("cs" . 2) ("lo" . 3) ("cc" . 3)
25                                      ("mi" . 4) ("pl" . 5)
26                                      ("vs" . 6) ("vc" . 7)
27                                      ("hi" . 8) ("ls" . 9)
28                                      ("ge" . 10) ("lt" . 11)
29                                      ("gt" . 12) ("le" . 13)
30                                      ("al" . 14)))
31
32
33
34(defun lookup-arm-condition-name (name)
35  (cdr (assoc name *arm-condition-names* :test #'string-equal)))
36
37(defun lookup-arm-condition-value (val)
38  (car (rassoc val *arm-condition-names* :test #'eq)))
39
40(defun need-arm-condition-name (name)
41  (or (lookup-arm-condition-name name)
42      (error "Unknown ARM condition name ~s." name)))
43
44(defvar *arm-constants* ())
45(defvar *lap-labels* ())
46
47
48
49
50
51
52(defun arm-subprimitive-offset (x)
53  (if (and x (or (symbolp x) (stringp x)))
54    (let* ((info (find x arm::*arm-subprims* :test #'string-equal :key #'ccl::subprimitive-info-name)))
55      (when info
56        (ccl::subprimitive-info-offset info)))))
57
58(defun arm-subprimitive-name (addr)
59  (let* ((info (find addr arm::*arm-subprims* :key #'ccl::subprimitive-info-offset)))
60    (when info
61      (string (ccl::subprimitive-info-name info)))))
62
63
64(defun arm-constant-index (form)
65  (let* ((idx (or (cdr (assoc form *arm-constants* :test 'equal))
66                  (let* ((n (length *arm-constants*)))
67                    (push (cons form n) *arm-constants*)
68                    n))))
69    (+ (ash (+ idx 2) arm::word-shift)  ; skip entrypoint, codevector
70       arm::misc-data-offset)))
71
72           
73
74(defun need-constant (form)
75  (if (ccl::quoted-form-p form)
76    (let* ((quoted (ccl::nx-unquote form)))
77      (if (null quoted)
78        arm::canonical-nil-value
79        (if (typep quoted '(signed-byte 30))
80          (ash quoted arm::fixnumshift)
81          (arm-constant-index quoted))))
82    (progn
83      (unless (and (consp form) (eq (car form) :$))
84        (error "Invalid constant syntax in ~s" form))
85      (destructuring-bind (val) (cdr form)
86        (eval val)))))
87               
88               
89(defstruct arm-instruction-template
90  name
91  ordinal                               ;if we need this
92  val
93  (flags 0)
94  operand-types
95  mask-list)
96
97(eval-when (:compile-toplevel :load-toplevel :execute)
98
99(defparameter *arm-operand-types*
100  #(:rd                                 ; destination register in bits 12:15
101    :rn                                 ; unshifted source/base reg in 16:19
102    :shifter                            ; composite operand for ALU ops
103    :mem12                              ; 12-bit address for LDR/STR/LDRB/STB
104    :reglist
105    :rnw                                ; rn, with optional writeback.
106    :uuoA                               ; GPR in UUO bits 8:11
107    :uuo-unary                          ; constant in UUO bits 12:15
108    :uuoB                               ; GPR in UUO bits 12:15
109    :rm
110    :b
111    :subprim
112    :mem8
113    :dd
114    :dm
115    :sd
116    :sm
117    :dn
118    :sn
119    :rde
120    :rs
121    :fpaddr
122    :@rn
123    :uuoC
124    :fpux
125    :imm16
126    :srcount                            ;single register count
127    :drcount
128    :spentry
129    ))
130
131(defun %encode-arm-operand-type (name)
132  (or (position name *arm-operand-types* :test #'eq)
133      (error "Unknown ARM operand type name ~s." name)))
134
135(defmacro encode-arm-operand-type (name)
136  (%encode-arm-operand-type name))
137
138(ccl::defenum (:prefix "ARM-INSTRUCTION-FLAG-")
139  non-conditional                       ;doesn't use standard condition field
140  prefer-separate-cond
141  )
142
143(defparameter *arm-instruction-flag-names*
144  `((:non-conditional . ,arm-instruction-flag-non-conditional)
145    (:prefer-separate-cond . ,arm-instruction-flag-prefer-separate-cond)
146    ))
147
148(defun %encode-arm-instruction-flag (name)
149  (flet ((encode-one-instruction-type (name)
150           (ash 1 (or (cdr (assoc name *arm-instruction-flag-names* :test #'eq))
151                      (error "Unknown ARM instruction type: ~s" name)))))
152    (if name
153      (if (atom name)
154        (encode-one-instruction-type name)
155        (let* ((mask 0))
156          (dolist (n name mask)
157            (setq mask (logior mask (encode-one-instruction-type n))))))
158      0)))
159)
160
161(defmacro encode-arm-instruction-flag (name)
162  (%encode-arm-instruction-flag name))
163
164(defvar *arm-instruction-ordinals* (make-hash-table :test #'equalp))
165
166
167
168(defun %define-arm-instruction (name value mask-list flags operand-types)
169  (make-arm-instruction-template :name name
170                                    :val value
171                                    :ordinal nil
172                                    :mask-list mask-list
173                                    :flags (or flags 0)
174                                    :operand-types operand-types))
175
176(defmacro define-arm-instruction (name operand-type-names value mask-list flag-names)
177  `(%define-arm-instruction ,(string-downcase name) ,value ',mask-list ,(%encode-arm-instruction-flag flag-names) ',(mapcar #'%encode-arm-operand-type operand-type-names) ))
178
179
180
181(defparameter *arm-instruction-table*
182  (vector
183
184   (define-arm-instruction clrex ()
185     #xf57ff01f
186     #xffffffff
187     (:non-conditional))
188   (define-arm-instruction isb ()
189     #xf57ff06f
190     #xffffffff
191     (:non-conditional))
192   (define-arm-instruction dmb ()
193     #xf57ff05f
194     #xffffffff
195     (:non-conditional))
196   (define-arm-instruction dsb ()
197     #xf57ff04f
198     #xffffffff
199     (:non-conditional))   
200
201   (define-arm-instruction vmul.f32 (:dd :dn :dm)
202     #xf3000d10
203     #xffa00f10
204     (:non-conditional))
205
206
207;;; UUOs.
208
209;;; Nullary UUOs
210   (define-arm-instruction uuo-alloc-trap ()
211     #x07f000f0
212     #x0fffffff
213     (:prefer-separate-cond))
214   (define-arm-instruction uuo-error-wrong-nargs ()
215     #x07f001f8
216     #x0fffffff
217     (:prefer-separate-cond))
218   (define-arm-instruction uuo-gc-trap ()
219     #x07f002f0
220     #x0fffffff 
221     (:prefer-separate-cond))
222   (define-arm-instruction uuo-debug-trap ()
223     #x07f003f0
224     #x0fffffff 
225     (:prefer-separate-cond))
226   (define-arm-instruction uuo-interrupt-now ()
227     #x07f004f0
228     #x0fffffff
229     (:prefer-separate-cond))
230   (define-arm-instruction uuo-suspend-now ()
231     #x07f005f0
232     #x0fffffff
233     (:prefer-separate-cond))
234;;; Misc format
235   (define-arm-instruction uuo-error-reg-not-lisptag (:uuoA :uuo-unary)
236     #x07f000f2
237     #x0ff000ff
238     (:prefer-separate-cond))
239   (define-arm-instruction uuo-error-reg-not-fulltag (:uuoA :uuo-unary)
240     #x07f000f3
241     #x0ff000ff
242     (:prefer-separate-cond))
243   (define-arm-instruction uuo-error-reg-not-xtype (:uuoA :uuo-unary)
244     #x07f000f4
245     #x0ff000ff
246     (:prefer-separate-cond))
247   (define-arm-instruction uuo-cerror-reg-not-lisptag (:uuoA :uuo-unary)
248     #x07f000fa
249     #x0ff000ff
250     (:prefer-separate-cond))
251   (define-arm-instruction uuo-cerror-reg-not-fulltag (:uuoA :uuo-unary)
252     #x07f000fb
253     #x0ff000ff
254     (:prefer-separate-cond))
255   (define-arm-instruction uuo-cerror-reg-not-xtype (:uuoA :uuo-unary)
256     #x07f000fc
257     #x0ff000ff
258     (:prefer-separate-cond))
259
260;;; Unary UUOs
261   (define-arm-instruction uuo-error-unbound (:uuoA)
262     #x07f000f9
263     #x0ffff0ff
264     (:prefer-separate-cond))
265   (define-arm-instruction uuo-cerror-unbound (:uuoA)
266     #x07f010f9
267     #x0ffff0ff
268     (:prefer-separate-cond))
269   (define-arm-instruction uuo-error-not-callable (:uuoA)
270     #x07f020f9
271     #x0ffff0ff
272     (:prefer-separate-cond))
273   (define-arm-instruction uuo-tlb-too-small (:uuoA)
274     #x07f030f1
275     #x0ffff0ff
276     (:prefer-separate-cond))
277   (define-arm-instruction uuo-error-no-throw-tag (:uuoA)
278     #x07f040f9
279     #x0ffff0ff
280     (:prefer-separate-cond))
281   (define-arm-instruction uuo-error-udf-call (:uuoA)
282     #x07f050f9
283     #x0ffff0ff
284     (:prefer-separate-cond))
285   (define-arm-instruction uuo-error-udf (:uuoA)
286     #x07f060f9
287     #x0ffff0ff
288     (:prefer-separate-cond))
289   
290;;; Binary UUOs
291   (define-arm-instruction uuo-error-vector-bounds (:uuoA :uuoB)
292     #x07f000ff
293     #x0fff00ff
294     (:prefer-separate-cond))
295   (define-arm-instruction uuo-error-array-bounds (:uuoA :uuoB)
296     #x07f100ff
297     #x0fff00ff
298     (:prefer-separate-cond))
299   (define-arm-instruction uuo-error-integer-divide-by-zero (:uuoA :uuoB)
300     #x07f200ff
301     #x0fff00ff
302     (:prefer-separate-cond))
303   (define-arm-instruction uuo-error-slot-unbound (:uuoA :uuoB :uuoC)
304     #x07f000fe
305     #x0ff000ff
306     (:prefer-separate-cond))
307   (define-arm-instruction uuo-eep-unresolved (:uuoA :uuoB)
308     #x07f400ff
309     #x0fff00ff
310     (:prefer-separate-cond))
311   (define-arm-instruction uuo-fpu-exception (:uuoA :uuoB)
312     #x07f500ff
313     #x0fff00ff
314     (:prefer-separate-cond))
315   (define-arm-instruction uuo-error-array-rank (:uuoA :uuoB)
316     #x07f600ff
317     #x0fff00ff
318     (:prefer-separate-cond))
319   (define-arm-instruction uuo-error-array-flags (:uuoA :uuoB)
320     #x07f700ff
321     #x0fff00ff
322     (:prefer-separate-cond))
323   (define-arm-instruction uuo-error-array-axis-bounds (:uuoC :uuoB :uuoA)
324     #x07f000f5
325     #x0ff000ff
326     (:prefer-separate-cond))
327   ;; Kernel services.
328   (define-arm-instruction uuo-kernel-service (:uuo-unary)
329     #x07f000fd
330     #x0fff00ff
331     (:prefer-separate-cond))
332
333   ;; movw, movt require ARMv6T2 or later
334   (define-arm-instruction movw (:rd :imm16)
335     #x03000000
336     #x0ff00000
337     ())
338   (define-arm-instruction movt (:rd :imm16)
339     #x03400000
340     #x0ff00000
341     ())
342   ;; This canonical NOP also requires ARMv6T2 or later.
343   (define-arm-instruction nop ()
344     #x0320f000
345     #x0fffffff
346     ())
347
348   (define-arm-instruction and (:rd :rn :shifter)
349     #x00000000
350     ((#x02000000 . #x0ff00000)
351      (#x00000000 . #x0ff00010)
352      (#x00000010 . #x0ff00090))
353     ())
354   (define-arm-instruction ands (:rd :rn :shifter)
355     #x00100000
356     ((#x02100000 . #x0ff00000)
357      (#x00100000 . #x0ff00010)
358      (#x00100010 . #x0ff00090))
359     ())
360   (define-arm-instruction eor (:rd :rn :shifter)
361     #x00200000
362     ((#x02200000 . #x0ff00000)
363      (#x00200000 . #x0ff00010)
364      (#x00200010 . #x0ff00090))
365     ())
366   (define-arm-instruction eors (:rd :rn :shifter)
367     #x00300000
368     ((#x02300000 . #x0ff00000)
369      (#x00300000 . #x0ff00010)
370      (#x00300010 . #x0ff00090))
371     ())
372   (define-arm-instruction sub (:rd :rn :shifter)
373     #x00400000
374     ((#x02400000 . #x0ff00000)
375      (#x00400000 . #x0ff00010)
376      (#x00400010 . #x0ff00090))
377     ())
378   (define-arm-instruction subs (:rd :rn :shifter)
379     #x00500000
380     ((#x02500000 . #x0ff00000)
381      (#x00500000 . #x0ff00010)
382      (#x00500010 . #x0ff00090))
383     ())
384   (define-arm-instruction rsb (:rd :rn :shifter)
385     #x00600000
386     ((#x02600000 . #x0ff00000)
387      (#x00600000 . #x0ff00010)
388      (#x00600010 . #x0ff00090))
389     ())
390   (define-arm-instruction rsbs (:rd :rn :shifter)
391     #x00700000
392     ((#x02700000 . #x0ff00000)
393      (#x00700000 . #x0ff00010)
394      (#x00700010 . #x0ff00090))
395     ())   
396   (define-arm-instruction add (:rd :rn :shifter)
397     #x00800000
398     ((#x02800000 . #x0ff00000)
399      (#x00800000 . #x0ff00010)
400      (#x00800010 . #x0ff00090))
401     ())
402   (define-arm-instruction adds (:rd :rn :shifter)
403     #x00900000
404     ((#x02900000 . #x0ff00000)
405      (#x00900000 . #x0ff00010)
406      (#x00900010 . #x0ff00090))
407     ())
408
409   (define-arm-instruction adc (:rd :rn :shifter)
410     #x00a00000
411     ((#x02a00000 . #x0ff00000)
412      (#x00a00000 . #x0ff00010)
413      (#x00a00010 . #x0ff00090))
414     ())
415   (define-arm-instruction adcs (:rd :rn :shifter)
416     #x00b00000
417     ((#x02b00000 . #x0ff00000)
418      (#x00b00000 . #x0ff00010)
419      (#x00b00010 . #x0ff00090))
420     ())
421   (define-arm-instruction sbc (:rd :rn :shifter)
422     #x00c00000
423     ((#x02c00000 . #x0ff00000)
424      (#x00c00000 . #x0ff00010)
425      (#x00c00010 . #x0ff00090))
426     ())
427   (define-arm-instruction sbcs (:rd :rn :shifter)
428     #x00d00000
429     ((#x02d00000 . #x0ff00000)
430      (#x00d00000 . #x0ff00010)
431      (#x00d00010 . #x0ff00090))
432     ())
433   (define-arm-instruction rsc (:rd :rn :shifter)
434     #x00e00000
435     ((#x02e00000 . #x0ff00000)
436      (#x00e00000 . #x0ff00010)
437      (#x00e00010 . #x0ff00090))
438     ())
439   (define-arm-instruction rscs (:rd :rn :shifter)
440     #x00f00000
441     ((#x02f00000 . #x0ff00000)
442      (#x00f00000 . #x0ff00010)
443      (#x00f00010 . #x0ff00090))
444     ())
445   (define-arm-instruction tst (:rn :shifter)
446     #x01100000
447     ((#x03100000 . #x0ff00000)
448      (#x01100000 . #x0ff00010)
449      (#x01100010 . #x0ff00090))
450     ())
451   (define-arm-instruction tsts (:rn :shifter)
452     #x01100000
453     ((#x03100000 . #x0ff00000)
454      (#x01100000 . #x0ff00010)
455      (#x01100010 . #x0ff00090))
456     ())
457   (define-arm-instruction orr (:rd :rn :shifter)
458     #x01800000
459     ((#x03800000 . #x0ff00000)
460      (#x01800000 . #x0ff00010)
461      (#x01800010 . #x0ff00090))
462     ())
463   (define-arm-instruction orrs (:rd :rn :shifter)
464     #x01900000
465     ((#x03900000 . #x0ff00000)
466      (#x01900000 . #x0ff00010)
467      (#x01900010 . #x0ff00090))
468     ())
469   (define-arm-instruction bic (:rd :rn :shifter)
470     #x01c00000
471     ((#x03c00000 . #x0ff00000)
472      (#x01c00000 . #x0ff00010)
473      (#x01c00010 . #x0ff00090))
474     ())
475   (define-arm-instruction bics (:rd :rn :shifter)
476     #x01d00000
477     ((#x03d00000 . #x0ff00000)
478      (#x01d00000 . #x0ff00010)
479      (#x01d00010 . #x0ff00090))
480     ())
481   (define-arm-instruction cmp (:rn :shifter)
482     #x01500000
483     ((#x03500000 . #x0ff00000)
484      (#x01500000 . #x0ff00010)
485      (#x01500010 . #x0ff00090))
486     ())
487   (define-arm-instruction cmps (:rn :shifter)
488     #x01500000
489     ((#x03500000 . #x0ff00000)
490      (#x01500000 . #x0ff00010)
491      (#x01500010 . #x0ff00090))
492     ())
493   (define-arm-instruction cmn (:rd :shifter)
494     #x01700000
495     ((#x03700000 . #x0ff00000)
496      (#x01700000 . #x0ff00010)
497      (#x01700010 . #x0ff00090))
498     ())
499
500   (define-arm-instruction cmns (:rd :shifter)
501     #x01700000
502     ((#x03700000 . #x0ff00000)
503      (#x01700000 . #x0ff00010)
504      (#x01700010 . #x0ff00090))
505     ())
506   
507
508 
509   (define-arm-instruction mov (:rd :shifter)
510     #x01a00000
511     ((#x03a00000 . #x0ff00000)
512      (#x01a00000 . #x0ff00010)
513      (#x01a00010 . #x0ff00090))
514     ())
515   (define-arm-instruction movs (:rd :shifter)
516     #x01b00000
517     ((#x03b00000 . #x0ff00000)
518      (#x01b00000 . #x0ff00010)
519      (#x01b00010 . #x0ff00090))
520     ())
521   (define-arm-instruction mvn (:rd :shifter)
522     #x01e00000
523     ((#x03e00000 . #x0ff00000)
524      (#x01e00000 . #x0ff00010)
525      (#x01e00010 . #x0ff00090))
526     ())
527   (define-arm-instruction mvns (:rd :shifter)
528     #x01f00000
529     ((#x03f00000 . #x0ff00000)
530      (#x01f00000 . #x0ff00010)
531      (#x01f00010 . #x0ff00090))
532     ())
533   (define-arm-instruction vpop1 (:rd)
534     #x049a0004
535     #x0fff0fff
536     ())
537   (define-arm-instruction spjump (:spentry)
538     #x0593f000
539     #x0ffff000
540     ())
541   (define-arm-instruction sploadlr (:spentry)
542     #x0593e000
543     #x0ffff000
544     ())
545   (define-arm-instruction ldr (:rd :mem12)
546     #x04100000
547     #x0c500000
548     ())
549   (define-arm-instruction ldrb (:rd :mem12)
550     #x04500000
551     #x0c500000
552     ())
553   (define-arm-instruction vpush1 (:rd)
554     #x052a0004
555     #x0fff0fff
556     ())
557   (define-arm-instruction str (:rd :mem12)
558     #x04000000
559     #x0c500000
560     ())
561   (define-arm-instruction strb (:rd :mem12)
562     #x04400000
563     #x0c500000
564     ())
565   (define-arm-instruction ldrh (:rd :mem8)
566     #x001000b0
567     #x0e3000f0
568     ())
569   (define-arm-instruction strh (:rd :mem8)
570     #x000000b0
571     #x0e3000f0
572     ())
573   (define-arm-instruction ldrsh (:rd :mem8)
574     #x001000f0
575     #x0e3000f0
576     ())
577   (define-arm-instruction ldrsb (:rd :mem8)
578     #x001000d0
579     #x0e3000f0
580     ())
581   (define-arm-instruction ldrd  (:rde :mem8)
582     #x000000d0
583     #x0e1000f0
584     ())
585   (define-arm-instruction strd  (:rde :mem8)
586     #x000000f0
587     #x0e1000f0
588     ())
589
590   (define-arm-instruction mul (:rn :rm :rs)
591     #x00000090
592     #x0ff000f0
593     ())
594   (define-arm-instruction muls (:rn :rm :rs)
595     #x00100090
596     #x0ff000f0
597     ())
598
599   (define-arm-instruction mla (:rn :rm :rs :rd)
600     #x00200090
601     #x0ff000f0
602     ())
603   (define-arm-instruction mlas (:rn :rm :rs :rd)
604     #x00300090
605     #x0ff000f0
606     ())
607   
608   (define-arm-instruction stm (:rnw :reglist)
609     #x08800000
610     #x0fd00000
611     ())
612   (define-arm-instruction stmia (:rnw :reglist)
613     #x08800000
614     #x0fd00000
615     ())
616   (define-arm-instruction stmea (:rnw :reglist)
617     #x08800000
618     #x0fd00000
619     ())
620   (define-arm-instruction ldmia (:rnw :reglist)
621     #x08900000
622     #x0fd00000
623     ())
624   (define-arm-instruction ldm (:rnw :reglist)
625     #x08900000
626     #x0fd00000
627     ())
628   (define-arm-instruction ldmfd (:rnw :reglist)
629     #x08900000
630     #x0fd00000
631     ())
632   (define-arm-instruction stmdb (:rnw :reglist)
633     #x09000000
634     #x0fd00000
635     ())
636   (define-arm-instruction stmfb (:rnw :reglist)
637     #x09000000
638     #x0fd00000
639     ())
640   (define-arm-instruction stmfd (:rnw :reglist)
641     #x09000000
642     #x0ff00000
643     ())
644   (define-arm-instruction ldmdb (:rnw :reglist)
645     #x09100000
646     #x0fd00000
647     ())
648   (define-arm-instruction ldmea (:rnw :reglist)
649     #x09100000
650     #x0fd00000
651     ())
652
653   (define-arm-instruction b (:b)
654     #x0a000000
655     #x0f000000
656     ())
657   (define-arm-instruction bl (:b)
658     #x0b000000
659     #x0f000000
660     ())
661 
662   (define-arm-instruction bx (:rm)
663     #x012fff10
664     #x0ffffff0
665     ())
666   (define-arm-instruction blx (:rm)
667     #x012fff30
668     #x0ffffff0
669     ())
670
671;;; VFP instructions
672   (define-arm-instruction fabsd (:dd :dm)
673     #x0eb00bc0
674     #x0fff0ff0
675     ())
676   (define-arm-instruction fabss (:sd :sm)
677     #x0eb00ac0
678     #x0fbf0fd0
679     ())
680   (define-arm-instruction fnegd (:dd :dm)
681     #x0eb10b40
682     #x0fff0ff0
683     ())
684   (define-arm-instruction fnegs (:sd :sm)
685     #x0eb10a40
686     #x0fbf0fd0
687     ())
688   (define-arm-instruction fsqrtd (:dd :dm)
689     #x0eb10bc0
690     #x0fff0ff0
691     ())
692   (define-arm-instruction fsqrts (:sd :sm)
693     #x0eb10ac0
694     #x0bff0fb0
695     ())   
696   (define-arm-instruction faddd (:dd :dn :dm)
697     #x0e300b00
698     #x0ff00ff0
699     ())
700   (define-arm-instruction fadds (:sd :sn :sm)
701     #x0e300a00
702     #x0f300f50
703     ())
704   (define-arm-instruction fmsr (:sn :rd)
705     #x0e000a10
706     #x0ff00f7f
707     ())
708   (define-arm-instruction fmrs (:rd :sn)
709     #x0e100a10
710     #x0ff00f7f
711     ())
712   (define-arm-instruction fmrrd (:rd :rn :dm)
713     #x0c500b10
714     #x0ff00ff0
715     ())
716   (define-arm-instruction fmdrr (:dm :rd :rn)
717     #x0c400b10
718     #x0ff00ff0
719     ())
720   (define-arm-instruction fsitod (:dd :sm)
721     #x0eb80bc0
722     #x0fbf0fc0
723     ())
724   (define-arm-instruction fsitos (:sd :sm)
725     #x0eb80ac0
726     #x0fbf0fc0
727     ())
728   (define-arm-instruction fcmped (:dd :dm)
729     #x0eb40bc0
730     #x0fff0fc0
731     ())
732   (define-arm-instruction fcmpes (:sd :sm)
733     #x0eb40ac0
734     #x0fff0fc0
735     ())
736   (define-arm-instruction fmstat ()
737     #x0ef1fa10
738     #x0fffffff
739     ())
740   (define-arm-instruction fsubd (:dd :dn :dm)
741     #x0e300b40
742     #x0fb00f50
743     ())
744   (define-arm-instruction fsubs (:sd :sn :sm)
745     #x0e300a40
746     #x0fb00f50
747     ())
748   (define-arm-instruction fmuld (:dd :dn :dm)
749     #x0e200b00
750     #x0ff00ff0
751     ())
752   (define-arm-instruction fmuls (:sd :sn :sm)
753     #x0e200a00
754     #x0fb00f50
755     ())
756   (define-arm-instruction fdivd (:dd :dn :dm)
757     #x0e800b00
758     #x0fb00ff0
759     ())
760   (define-arm-instruction fdivs (:sd :sn :sm)
761     #x0e800a00
762     #x0fb00f50
763     ())
764
765   (define-arm-instruction fmacd (:dd :dn :dm)
766     #x0e000b00
767     #x0fb00f50
768     ())
769   (define-arm-instruction fmacs (:sd :sn :sm)
770     #x0e000a00
771     #x0fb00f50
772     ())
773
774   (define-arm-instruction fcpyd (:dd :dm)
775     #x0eb00b40
776     #x0fbf0ff0
777     ())
778   (define-arm-instruction fcpys (:sd :sm)
779     #x0eb00a40
780     #x0fbf0fc0
781     ())
782   (define-arm-instruction fcvtsd (:sd :dm)
783     #x0eb70bc0
784     #x0fbf0ff0
785     ())
786   (define-arm-instruction fcvtds (:dd :sm)
787     #x0eb70ac0
788     #x0ff70ac0
789     ())
790   (define-arm-instruction fmxr (:fpux :rd)
791     #x0ee00a10
792     #x0ff00fff
793     ())
794   (define-arm-instruction fmrx (:rd :fpux)
795     #x0ef00a10
796     #x0ff00fff
797     ())
798   (define-arm-instruction smull (:rd :rn :rm :rs)
799     #x00c00090
800     #x0ff000f0
801     ())
802   (define-arm-instruction smulls (:rd :rn :rm :rs)
803     #x00d00090
804     #x0ff000f0
805     ())
806   (define-arm-instruction umull (:rd :rn :rm :rs)
807     #x00800090
808     #x0ff000f0
809     ())
810   (define-arm-instruction umulls (:rd :rn :rm :rs)
811     #x00900090
812     #x0ff000f0
813     ())
814
815   (define-arm-instruction fstd (:dd :fpaddr)
816     #x0d000b00
817     #x0f700f00
818     ())
819   (define-arm-instruction fsts (:sd :fpaddr)
820     #x0d000a00
821     #x0f300f00
822     ())
823   (define-arm-instruction fstmdbs (:sd :rnw :srcount)
824     #x0d200a00
825     #x0fb00f00
826     ())
827   (define-arm-instruction fstmias (:sd :rnw :srcount)
828     #x0c800a00
829     #x0fd00f00
830     ())
831   (define-arm-instruction fstmdbd (:dd :rnw :drcount)
832     #x0d200b00
833     #x0ff00f00
834     ())
835   (define-arm-instruction fstmiad (:sd :rnw :srcount)
836     #x0c800b00
837     #x0fd00f00
838     ())
839   (define-arm-instruction fldd (:dd :fpaddr)
840     #x0d100b00
841     #x0f700f00
842     ())     
843   (define-arm-instruction flds (:sd :fpaddr)
844     #x0d100a00
845     #x0f300f00
846     ())
847   (define-arm-instruction fldmias (:sd :rnw :srcount)
848     #x0c900a00
849     #x0f900f00
850     ())
851   (define-arm-instruction fldmiad (:dd :rnw :drcount)
852     #x0c900b00
853     #x0f900f00
854     ())     
855   (define-arm-instruction ftosid (:sd :dm)
856     #x0ebd0b40
857     #x0fbf0fc0
858     ())
859   (define-arm-instruction ftosizd (:sd :dm)
860     #x0ebd0bc0
861     #x0fbf0fc0
862     ())
863   (define-arm-instruction ftosis (:sd :sm)
864     #x0ebd0a40
865     #x0fbf0fc0
866     ())
867   (define-arm-instruction ftosizs (:sd :sm)
868     #x0ebd0ac0
869     #x0fbf0fc0
870     ())   
871   (define-arm-instruction ldrex (:rd :@rn)
872     #x01900f9f
873     #x0ff00fff
874     ())
875   (define-arm-instruction strex (:rd :rm :@rn)
876     #x01800f90
877     #x0ff00ff0
878     ())
879   (define-arm-instruction clz (:rd :rm)
880     #x016f0f10
881     #x0fff0ff0
882     ())
883 ))
884
885(dotimes (i (length *arm-instruction-table*))
886  (let* ((template (svref *arm-instruction-table* i))
887         (name (arm-instruction-template-name template)))
888    (setf (arm-instruction-template-ordinal template) i
889          (gethash name *arm-instruction-ordinals*) i)))
890
891   
892
893
894
895(defun lookup-arm-instruction (name)
896  ;; return (values instruction template & condition value), or (NIL NIL)
897  (let* ((cond-value #xe)              ;always
898         (string (string name))
899         (len (length string))
900         (ordinal (gethash string *arm-instruction-ordinals*))
901         (template (if ordinal (aref *arm-instruction-table* ordinal))))
902    (if template
903      (if (logtest (encode-arm-instruction-flag :non-conditional) (arm-instruction-template-flags template))
904        (let* ((cond (ldb (byte 4 28) (arm-instruction-template-val template))))
905          (values template cond cond))
906        (values template cond-value nil))
907      (if (> len 2)
908        (let* ((cond-name (make-string 2)))
909          (declare (dynamic-extent cond-name))
910          (setf (schar cond-name 0)
911                (schar string (- len 2))
912                (schar cond-name 1)
913                (schar string (- len 1)))
914          (if (setq cond-value (lookup-arm-condition-name cond-name))
915            (let* ((prefix-len (- len 2))
916                   (prefix (make-string prefix-len)))
917              (declare (dynamic-extent prefix)
918                       (fixnum prefix-len))
919              (dotimes (i prefix-len)
920                (setf (schar prefix i) (schar string i)))
921              (if (setq template
922                        (progn
923                          (setq ordinal (gethash prefix *arm-instruction-ordinals*))
924                          (when ordinal
925                            (svref *arm-instruction-table* ordinal))))
926                (if (logbitp (encode-arm-instruction-flag :non-conditional) (arm-instruction-template-flags template))
927                  (values nil nil nil)
928                  (values template cond-value t))
929                (values nil nil nil)))
930            (values nil nil nil)))
931        (values nil nil nil)))))
932
933
934
935(defun arm-rotate-left (u32 nbits)
936  (assert (and (evenp nbits)
937               (>= nbits 0)
938               (< nbits 32)))
939  (let* ((r (- 32 nbits))
940         (mask (1- (ash 1 nbits))))
941    (logand #xffffffff
942            (logior (ash u32 nbits)
943                    (logand mask
944                            (ash  u32 (- r)))))))
945
946;;; Return a 12-bit value encoding u32 as an 8-bit constant rotated
947;;; by an even number of bits if u32 can be encoded that way, nil
948;;; otherwise.
949#-arm-target
950(defun encode-arm-immediate (u32)
951  (do* ((u32 (logand #xffffffff u32))
952        (rot 0 (+ rot 2)))
953       ((= rot 32) (values nil nil))
954    (let* ((a (arm-rotate-left u32 rot)))
955      (when (<= a #xff)
956        (return (logior (ash rot 7) a))))))
957
958#+arm-target
959(ccl::defarmlapfunction encode-arm-immediate ((u32 arg_z))
960  (check-nargs 1)
961  (extract-typecode imm0 u32)
962  (cmp imm0 (:$ arm::tag-fixnum))
963  (moveq imm0 (:asr u32 (:$ arm::fixnumshift)))
964  (beq @got)
965  (cmp imm0 (:$ arm::subtag-bignum))
966  (uuo-error-reg-not-xtype (:? ne) u32 (:$ arm::xtype-integer))
967  (ldr imm0 (:@ u32 (:$ arm::misc-data-offset)))
968  @got
969  (mov imm1 (:$ 32))
970  (mov imm2 imm0)
971  @loop
972  (cmp imm2 (:$ 256))
973  (blo @win)
974  (subs imm1 imm1 (:$ 2))
975  (moveq arg_z 'nil)
976  (bxeq lr)
977  (mov imm2 (:ror imm0 imm1))
978  (b @loop)
979  @win
980  (rsb imm1 imm1 (:$ 32))
981  (orr imm0 imm2 (:lsl imm1 (:$ 7)))
982  (box-fixnum arg_z imm0)
983  (bx lr))
984
985(eval-when (:execute :load-toplevel)
986  (defstruct (instruction-element (:include ccl::dll-node))
987    address
988    (size 0))
989
990;;; A LAP-INSTRUCTION's field-values list contains (byte-spec . value)
991;;; pairs, where the byte-spec is encoded as a fixnum.  If the BYTE-SIZE
992;;; of the byte-spec is non-zero, the value is to be inserted in the
993;;; instruction by DPB; if the BYTE-SIZE is zero, the BYTE-POSITION of
994
995;;; the byte-spec is used to select a function which affects arbitrary
996;;; bitfields in the instruction.  (E.g., a negative constant in an ADD
997;;; instruction might turn the instruction into a SUB.)
998;;; The relationship between logical operands and field-values isn't
999;;; necessarily 1:1.
1000;;; For vinsn expansion, the field values with constant values can
1001;;; be applied at vinsn-definition time.
1002 
1003  (defstruct (lap-instruction (:include instruction-element (size 4))
1004                              (:constructor %make-lap-instruction (source)))
1005    source                              ; for LAP, maybe vinsn-template
1006    (opcode-high 0)
1007    (opcode-low 0)
1008    )
1009
1010   
1011  (defstruct (lap-label (:include instruction-element)
1012                            (:constructor %%make-lap-label (name)))
1013    name
1014    refs))
1015
1016(ccl::def-standard-initial-binding *lap-label-freelist* (ccl::make-dll-node-freelist))
1017(ccl::def-standard-initial-binding *lap-instruction-freelist* (ccl::make-dll-node-freelist))
1018
1019
1020(defun set-opcode-values (high low bytespec value)
1021  (declare (type (unsigned-byte 16) low high))
1022  (let* ((width (byte-size bytespec))
1023         (pos (byte-position bytespec)))
1024    (declare (type (unsigned-byte 5) width pos))
1025    (cond ((<= (the fixnum (+ width pos)) 16)
1026           (values high (dpb value bytespec low)))
1027          ((>= pos 16)
1028           (values (dpb value (byte width (- pos 16)) high) low))
1029          ;; Branch displacements are about the only things
1030          ;; that span the two halves of an instruction.
1031          (t
1032           (let* ((low-width (- 16 pos))
1033                  (high-width (- width low-width)))
1034             (declare (fixnum low-width high-width))
1035             (values (dpb (ldb (byte high-width low-width) value)
1036                          (byte high-width 0)
1037                          high)
1038                     (dpb (ldb (byte low-width 0) value)
1039                        (byte low-width pos)
1040                        low)))))))
1041
1042
1043(defun set-field-value (instruction bytespec value)
1044  (let* ((low (lap-instruction-opcode-low instruction))
1045         (high (lap-instruction-opcode-high instruction)))
1046    (declare (type (unsigned-byte 16) low high))
1047    (multiple-value-bind (new-high new-low)
1048        (set-opcode-values high low bytespec value)
1049      (declare (type (unsigned-byte 16) new-low new-high))
1050      (unless (eql low new-low)
1051        (setf (lap-instruction-opcode-low instruction) new-low))
1052      (unless (eql high new-high)
1053        (setf (lap-instruction-opcode-high instruction) new-high)))))
1054
1055
1056(defun get-opcode-field (high low bytespec)
1057  (declare (fixnum high low))
1058  (let* ((width (byte-size bytespec))
1059         (pos (byte-position bytespec)))
1060    (declare (fixnum width pos))
1061    (cond ((<= (the fixnum (+ width pos)) 16)
1062           (ldb bytespec low))
1063          ((>= pos 16)
1064           (ldb (byte width (- pos 16)) high))
1065          ;; Branch displacements are about the only things
1066          ;; that span the two halves of an instruction.
1067          (t
1068           (let* ((low-width (- 16 pos))
1069                  (high-width (- width low-width)))
1070             (declare (fixnum low-width high-width))
1071             (dpb (ldb (byte high-width 0) high)
1072                  (byte high-width low-width)
1073                  (ldb (byte low-width pos) low)))))))
1074 
1075(defun get-field-value (instruction bytespec)
1076  (get-opcode-field (lap-instruction-opcode-high instruction)
1077                    (lap-instruction-opcode-low instruction)
1078                    bytespec))
1079
1080
1081(defun need-arm-gpr (form)
1082  (or (get-arm-gpr form)
1083      (error "Expected an ARM general-purpose register, got ~s" form)))
1084
1085(defun need-arm-sfpr (form)
1086  (or (get-arm-sfpr form)
1087      (error "Expected an ARM single FP register, got ~s" form)))
1088
1089(defun need-arm-dfpr (form)
1090  (or (get-arm-dfpr form)
1091      (error "Expected an ARM double FP register, got ~s" form)))
1092
1093(defun encode-arm-shift-type (op)
1094  (case op
1095    (:lsl 0)
1096    (:lsr 1)
1097    (:asr 2)
1098    (:ror 3)))
1099
1100
1101(defconstant opcode-and 0)
1102(defconstant opcode-eor 1)
1103(defconstant opcode-sub 2)
1104(defconstant opcode-rsb 3)
1105(defconstant opcode-add 4)
1106(defconstant opcode-adc 5)
1107(defconstant opcode-sbc 6)
1108(defconstant opcode-rsc 7)
1109(defconstant opcode-tst 8)
1110(defconstant opcode-teq 9)
1111(defconstant opcode-cmp 10)
1112(defconstant opcode-cmn 11)
1113(defconstant opcode-orr 12)
1114(defconstant opcode-mov 13)
1115(defconstant opcode-bic 14)
1116(defconstant opcode-mvn 15)
1117
1118(defparameter *equivalent-complemented-opcodes*
1119  (vector opcode-bic                    ;and->bic
1120          nil                           ;eor->
1121          nil                           ;sub->
1122          nil                           ;rsb->
1123          nil                           ;add->
1124          opcode-sbc                    ;adc->sbc
1125          opcode-adc                    ;sbc->adc
1126          nil                           ;rsc->
1127          nil                           ;tst->
1128          nil                           ;teq->
1129          nil                           ;cmp->
1130          nil                           ;cmn->
1131          nil                           ;orr->
1132          opcode-mvn                    ;mov->mvn
1133          opcode-and                    ;bic->and
1134          opcode-mov                    ;mvn->mov
1135          ))
1136
1137(defparameter *equivalent-negated-opcodes*
1138  (vector nil                           ;and->
1139          nil                           ;eor->
1140          opcode-add                    ;sub->add
1141          nil                           ;rsb->
1142          opcode-sub                    ;add->sub
1143          nil                           ;adc->
1144          nil                           ;sbc->
1145          nil                           ;rsc->
1146          nil                           ;tst->
1147          nil                           ;teq->
1148          opcode-cmn                    ;cmp->cmn
1149          opcode-cmp                    ;cmn->cmp
1150          nil                           ;orr->
1151          nil                           ;mov->
1152          nil                           ;bic->
1153          nil                           ;mvn->
1154          ))
1155
1156
1157   
1158(defun parse-rd-operand (form instruction)
1159  (set-field-value instruction (byte 4 12) (need-arm-gpr form)))
1160
1161(defun parse-rn-operand (form instruction)
1162  (set-field-value instruction (byte 4 16) (need-arm-gpr form)))
1163
1164(defun parse-shifter-operand (form instruction)
1165  (if (atom form)
1166    ;; rm is shorthand for (:lsl rm (:$ 0)); the :lsl is encoded as 0.
1167    (set-field-value instruction (byte 12 0) (need-arm-gpr form))
1168    (if (ccl::quoted-form-p form)
1169      (insert-shifter-constant (need-constant form) instruction)
1170      (let* ((op (car form)))
1171        (ecase op
1172          (:$ (destructuring-bind (value) (cdr form)
1173                (insert-shifter-constant (eval value) instruction)))
1174          (:rrx (destructuring-bind (reg) (cdr form)
1175                  (set-field-value instruction (byte 12 0)
1176                                   (logior (need-arm-gpr reg)
1177                                           (ash (encode-arm-shift-type :ror) 5)))))
1178          ((:lsl :lsr :asr :ror)
1179           (destructuring-bind (reg count) (cdr form)
1180             (if (atom count)
1181               (set-field-value instruction (byte 12 0)
1182                                (logior (need-arm-gpr reg)
1183                                        (ash 1 4)
1184                                        (ash (encode-arm-shift-type op) 5)
1185                                        (ash (need-arm-gpr count) 8)))
1186               (ecase (car count)
1187                 (:$ (destructuring-bind (countval) (cdr count)
1188                       (if (and (eql (logand (eval countval) 31) 0)
1189                                (eq op :ror))
1190                         (error "Invalid shift count for :ROR : ~s." countval))
1191                       (set-field-value instruction (byte 12 0)
1192                                        (logior (need-arm-gpr reg)
1193                                                (ash (encode-arm-shift-type op) 5)
1194                                                (ash (logand 31 (eval countval)) 7))))))))))))))
1195     
1196(defun insert-shifter-constant (value instruction)
1197  (let* ((constant (encode-arm-immediate value)))
1198    (cond (constant
1199            (set-field-value instruction (byte 12 0) constant)
1200            (set-field-value instruction (byte 1 25) 1))
1201          (t
1202           ;; If value couldn't be encoded but its complement can be
1203           ;; and there's an instruction that can operate on complemented
1204           ;; values, change the instruction and encode the complemented
1205           ;; value.  If that doesn't work, try negating the value and
1206           ;; seeing if there's an equivalent instruction that could use
1207           ;; that.  If none of this works, complain that the value can't
1208           ;; be encoded.
1209           (let* ((op (get-field-value instruction (byte 4 21)))
1210                  (newop nil))
1211             (if (or (and (setq constant (encode-arm-immediate (lognot value)))
1212                          (setq newop (svref *equivalent-complemented-opcodes* op)))
1213                     (and (setq constant (encode-arm-immediate (- value)))
1214                          (setq newop (svref *equivalent-negated-opcodes* op))))
1215               (progn
1216                 (set-field-value instruction (byte 1 25) 1)
1217                 (set-field-value instruction (byte 12 0) constant)
1218                 (set-field-value instruction (byte 4 21) newop))
1219               (error "Can't encode ARM constant ~s." value)))))))
1220
1221(defun set-opcode-value-from-addressing-mode (high mode constant-index)
1222  ;; Look at mode and set P/W/U bits.  If CONSTANT-INDEX is
1223  ;; true, the U bit depends on the sign of the constant.
1224  (ecase mode           
1225    ((:@ :+@ :+@! :@!)
1226     ;; Preindexed, no writeback unless :[+]@! , add register operands.
1227     (unless constant-index
1228       (setq high (logior high (ash 1 (- 23 16)))))
1229     (when (or (eq mode :+@!)
1230               (eq mode :@!))
1231       (setq high (logior high (ash 1 (- 21 16)))))
1232     (setq high (logior high (ash 1 (- 24 16)))))
1233    ((:-@ :-@!)
1234     ;; Preindexed. Leave the U bit clear, maybe set W if writeback.
1235     (when (eq mode :-@!)
1236       (setq high (logior high (ash 1 (- 21 16)))))
1237     (setq high (logior high (ash 1 (- 24 16)))))
1238    ((:@+ :@-)
1239     ;; Postindex; writeback is implicit (and setting P and W would
1240     ;; change the instruction.)
1241     (unless (or (eq mode :@-) constant-index)
1242       (setq high (logior high (ash 1 (- 23 16)))))))
1243  high)
1244
1245
1246(defun set-addressing-mode (instruction mode constant-index)
1247  (setf (lap-instruction-opcode-high instruction)
1248        (set-opcode-value-from-addressing-mode
1249         (lap-instruction-opcode-high instruction)
1250         mode
1251         constant-index)))
1252
1253
1254;;; "general" address operand, as used in LDR/LDRB/STR/STRB
1255(defun parse-m12-operand (form instruction)
1256  (if (atom form)
1257    (error "Invalid memory operand ~s" form)   
1258    (let* ((mode (car form)))
1259      (if (eq mode :=)
1260        (destructuring-bind (label) (cdr form)
1261          (when (arm::arm-subprimitive-offset label)
1262            (error "Invalid label in ~s." form))
1263          (set-field-value instruction (byte 4 16) arm::pc)
1264          (set-field-value instruction (byte 1 24) 1) ;P bit
1265          ;; Insert function will have to set U bit appropriately.
1266          (lap-note-label-reference label instruction :mem12))
1267        (destructuring-bind (rn &optional (index '(:$ 0) index-p)) (cdr form)
1268          (unless (or index-p (eq mode :@))
1269            (error "missing index in memory operand ~s." form))
1270          (set-field-value instruction (byte 4 16) (need-arm-gpr rn))
1271          (let* ((quoted (ccl::quoted-form-p index))
1272                 (index-op (if quoted :quote (and (consp index) (car index))))
1273                 (constant-index (or quoted (eq index-op :$))))
1274            (cond (constant-index
1275                   (destructuring-bind (val) (cdr index)
1276                     (let* ((constval (if quoted
1277                                        (need-constant index)
1278                                        (eval val))))
1279                       (if (< constval 0)
1280                         (setq constval (- constval))
1281                         ;; das u bit
1282                         (set-field-value instruction (byte 1 23) 1))
1283                       (unless (typep constval '(unsigned-byte 12))
1284                         (warn "constant offset too large : ~s" constval))
1285                       (set-field-value instruction (byte 12 0) constval))))
1286                  (t
1287                   (set-field-value instruction (byte 1 25) 1)
1288                   (if (atom index)
1289                     (set-field-value instruction (byte 12 0) (need-arm-gpr index))
1290                     ;; Shifts here are always by a constant (not another reg)
1291                     (if (eq index-op :rrx)
1292                       (destructuring-bind (rm) (cdr index)
1293                         (set-field-value instruction (byte 12 0)
1294                                          (logior (need-arm-gpr rm)
1295                                                  (ash (encode-arm-shift-type :ror) 5))))
1296                     
1297                       (destructuring-bind (rm shift-expr) (cdr index)
1298                         (unless (and (consp shift-expr)
1299                                      (eq (car shift-expr) :$))
1300                           (error "Shift count must be immediate : ~s" shift-expr))
1301                         (destructuring-bind (count-expr) (cdr shift-expr)
1302                           (set-field-value instruction (byte 12 0)
1303                                            (logior (need-arm-gpr rm)
1304                                                    (ash (encode-arm-shift-type
1305                                                          index-op) 5)
1306                                                    (ash (logand 31 (eval count-expr))
1307                                                         7)))))))))
1308            (set-addressing-mode instruction mode constant-index)))))))
1309
1310(defun parse-reglist-operand (form instruction)
1311  (let* ((mask 0))
1312    (if (eq (car form) :$)
1313      (setq mask (cadr form))
1314      (dolist (r form)
1315        (let* ((regno (need-arm-gpr r)))
1316          (when (logbitp regno mask)
1317            (warn "Duplicate register ~s in ~s." r form))
1318          (setq mask (logior mask (ash 1 regno))))))
1319    (if (zerop mask)
1320      (error "Empty register list ~s." form)
1321      (set-field-value instruction (byte 16 0) mask))))
1322
1323(defun parse-rnw-operand (form instruction)
1324  (if (atom form)
1325    (set-field-value instruction (byte 4 16) (need-arm-gpr form))
1326    (if (eq (car form) :!)
1327      (destructuring-bind (rn) (cdr form)
1328        (set-field-value instruction (byte 1 21) 1)
1329        (set-field-value instruction (byte 4 16) (need-arm-gpr rn)))
1330      (error "Unrecognized writeback indicator in ~s." form))))
1331
1332(defun parse-uuoA-operand (form instruction)
1333  (set-field-value instruction (byte 4 8) (need-arm-gpr form)))
1334
1335(defun parse-uuo-unary-operand (form instruction)
1336  (set-field-value instruction (byte 8 12) (need-constant form)))
1337
1338(defun parse-uuoB-operand (form instruction)
1339  (set-field-value instruction (byte 4 12) (need-arm-gpr form)))
1340
1341(defun parse-uuoC-operand (form instruction)
1342  (set-field-value instruction (byte 4 16) (need-arm-gpr form)))
1343
1344(defun parse-fpux-operand (form instruction)
1345  (let* ((regno (if (typep form '(unsigned-byte 4))
1346                  form
1347                  (ecase form
1348                    (:fpsid 0)
1349                    (:fpscr 1)
1350                    (:fpexc 8)))))
1351    (set-field-value instruction (byte 4 16) regno)))
1352
1353(defun parse-imm16-operand (form instruction)
1354  (unless (and (consp form)
1355               (or (eq (car form) :$)
1356                   (eq (car form) 'quote))
1357               (consp (cdr form))
1358               (null (cddr form)))
1359    (error "Bad 16-bit immediate operand: ~s" form))
1360  (let* ((val (eval (cadr form))))
1361    (when (eq (car form) 'quote)
1362      (setq val (ash val arm::fixnumshift)))
1363    (set-field-value instruction (byte 12 0) (ldb (byte 12 0) val))
1364    (set-field-value instruction (byte 4 16) (ldb (byte 4 12) val))))
1365   
1366(defun parse-srcount-operand (form instruction)
1367  (let* ((val (eval form)))
1368    (unless (and (typep val 'fixnum)
1369                 (> (the fixnum val) 0)
1370                 (< (the fixnum val) 33))
1371      (ccl::report-bad-arg form `(integer (0) (33))))
1372    (set-field-value instruction (byte 8 0) val)))
1373
1374(defun parse-drcount-operand (form instruction)
1375  (let* ((val (eval form)))
1376    (unless (and (typep val 'fixnum)
1377                 (> (the fixnum val) 0)
1378                 (< (the fixnum val) 33))
1379      (ccl::report-bad-arg form `(integer (0) (33))))
1380    (set-field-value instruction (byte 7 1) val)))
1381
1382(defun parse-rm-operand (form instruction)
1383  (set-field-value instruction (byte 4 0) (need-arm-gpr form)))
1384
1385(defun parse-b-operand (form instruction)
1386  (lap-note-label-reference form instruction :b))
1387
1388(defun parse-subprim-operand (form instruction)
1389  (declare (ignore form instruction))
1390  (ccl::compiler-bug "Obsolete operand type :SUBPRIM."))
1391
1392(defun parse-spentry-operand (form instruction)
1393  (multiple-value-bind (addr name)
1394      (if (typep form 'fixnum)
1395        (values form
1396                (arm-subprimitive-name form))
1397        (values (arm-subprimitive-offset form)
1398                form))
1399    (unless (and name addr)
1400      (error "~s is not the name or address of an ARM subprimitive." form))
1401    (set-field-value instruction (byte 12 0) addr)))
1402
1403
1404   
1405(defun parse-m8-operand (form instruction)
1406  (if (atom form)
1407    (error "Invalid memory operand ~s." form)
1408    (let* ((mode (car form))
1409           (constant-index nil))
1410      (destructuring-bind (rn index) (cdr form)
1411        (set-field-value instruction (byte 4 16) (need-arm-gpr rn))
1412        (cond ((atom index)
1413               (set-field-value instruction (byte 4 0) (need-arm-gpr index)))
1414              (t (unless (eq (car index) :$)
1415                   (error "Invalid index: ~s." index))
1416                 (destructuring-bind (val) (cdr index)
1417                   (let* ((value (eval val)))
1418                     (setq constant-index t)
1419                     (if (< value 0)
1420                       (setq value (- value))
1421                       (set-field-value instruction (byte 1 23) 1))
1422                     (set-field-value instruction (byte 1 22) 1)
1423                     (set-field-value instruction (byte 4 0) (ldb (byte 4 0) value))
1424                     (set-field-value instruction (byte 4 8) (ldb (byte 4 4) value)))))))
1425      (set-addressing-mode instruction mode constant-index))))
1426
1427(defun parse-dd-operand (form instruction)
1428  (set-field-value instruction (byte 4 12) (need-arm-dfpr form)))
1429
1430(defun parse-dm-operand (form instruction)
1431  (set-field-value instruction (byte 4 0) (need-arm-dfpr form)))
1432
1433(defun parse-sd-operand (form instruction)
1434  (let* ((val (need-arm-sfpr form)))
1435    (set-field-value instruction (byte 4 12) (ash val -1))
1436    (set-field-value instruction (byte 1 22) (logand val 1))))
1437
1438(defun parse-sm-operand (form instruction)
1439  (let* ((val (need-arm-sfpr form)))
1440    (set-field-value instruction (byte 4 0) (ash val -1))
1441    (set-field-value instruction (byte 1 5) (logand val 1))))
1442
1443(defun parse-dn-operand (form instruction)
1444  (set-field-value instruction (byte 4 16) (need-arm-dfpr form)))       
1445                             
1446(defun parse-sn-operand (form instruction)
1447  (let* ((val (need-arm-sfpr form)))
1448    (set-field-value instruction (byte 4 16) (ash val -1))
1449    (set-field-value instruction (byte 1 7) (logand val 1))))
1450
1451(defun parse-rde-operand (form instruction)
1452  (let* ((val (need-arm-gpr form)))
1453    (when (oddp val)
1454      (error "Register must be even-numbered: ~s." form))
1455    (set-field-value instruction (byte 4 12) val)))
1456
1457(defun parse-rs-operand (form instruction)
1458  (set-field-value instruction (byte 4 8) (need-arm-gpr form)))
1459
1460(defun parse-fpaddr-operand (form instruction)
1461  (if (atom form)
1462    (error "Invalid FP address: ~s" form)
1463    (if (eq (car form) :=)
1464      (destructuring-bind (label) (cdr form)
1465        (set-field-value instruction (byte 4 16) pc)
1466        (lap-note-label-reference label instruction :fpmem))
1467      (destructuring-bind (op rn offset) form
1468        (unless (eq op :@)
1469          (error "Invalid FP addressing mode ~s in ~s." op form))
1470        (set-field-value instruction (byte 4 16) (need-arm-gpr rn))
1471        (unless (and (consp offset) (eq (car offset) :$))
1472          (error "Invalid FP address offset ~s in ~s." offset form))
1473        (destructuring-bind (offset-form) (cdr offset)
1474          (let* ((offset-val (eval offset-form)))
1475            (when (logtest offset-val 3)
1476              (error "FP address offset ~s must be a multiple of 4 in ~s." offset form))
1477            (if (< offset-val 0)
1478              (setq offset-val (- offset-val))
1479              (set-field-value instruction (byte 1 23) 1))
1480            (set-field-value instruction (byte 8 0) (ash offset-val -2))))))))
1481
1482(defun parse-@rn-operand (form instruction)
1483  (when (or (atom form)
1484          (not (eq (car form) :@)))
1485    (error "Invalid register indirect operand: ~s" form))
1486  (destructuring-bind (rn) (cdr form)
1487    (set-field-value instruction (byte 4 16) (need-arm-gpr rn))))
1488 
1489(defparameter *arm-operand-parsers*
1490    #(parse-rd-operand
1491      parse-rn-operand
1492      parse-shifter-operand
1493      parse-m12-operand
1494      parse-reglist-operand
1495      parse-rnw-operand
1496      parse-uuoa-operand
1497      parse-uuo-unary-operand
1498      parse-uuob-operand
1499      parse-rm-operand
1500      parse-b-operand
1501      parse-subprim-operand
1502      parse-m8-operand
1503      parse-dd-operand
1504      parse-dm-operand
1505      parse-sd-operand
1506      parse-sm-operand
1507      parse-dn-operand
1508      parse-sn-operand
1509      parse-rde-operand
1510      parse-rs-operand
1511      parse-fpaddr-operand
1512      parse-@rn-operand
1513      parse-uuoc-operand
1514      parse-fpux-operand
1515      parse-imm16-operand
1516      parse-srcount-operand
1517      parse-drcount-operand
1518      parse-spentry-operand
1519      ))
1520
1521
1522
1523(defun make-lap-instruction (form)
1524  (let* ((insn (ccl::alloc-dll-node *lap-instruction-freelist*)))
1525    (if (typep insn 'lap-instruction)
1526      (progn
1527        (setf (lap-instruction-source insn) form
1528              (lap-instruction-address insn) nil
1529              (lap-instruction-opcode-low insn) 0
1530              (lap-instruction-opcode-high insn) 0)
1531        insn)
1532      (%make-lap-instruction form))))
1533
1534(defun emit-lap-instruction-element (insn seg)
1535  (ccl::append-dll-node insn seg)
1536  (let* ((addr (let* ((prev (ccl::dll-node-pred insn)))
1537                 (if (eq prev seg)
1538                   0
1539                   (the fixnum (+ (the fixnum (instruction-element-address prev))
1540                                  (the fixnum (instruction-element-size prev))))))))
1541    (setf (instruction-element-address insn) addr))
1542  insn)
1543 
1544;;; FORM is a list and its car isn't a pseudo-op or lapmacro; try to
1545;;; generate an instruction.
1546(defun assemble-instruction (seg form)
1547  (let* ((insn (make-lap-instruction form)))
1548    (destructuring-bind (name . opvals) form
1549      (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name)
1550        (unless template
1551          (error "Unknown ARM instruction - ~s" form))
1552        (let* ((cond-indicator (and (consp (car opvals))
1553                                    (caar opvals))))
1554          (when (or (eq cond-indicator :?)
1555                    (eq cond-indicator :~))
1556            (let* ((condform (pop opvals)))
1557              (destructuring-bind (q cond-name) condform
1558                (declare (ignore q))
1559                (let* ((c (need-arm-condition-name cond-name)))
1560                  (when (eq cond-indicator :~)
1561                    (if (< c 14)
1562                      (setq c (logxor c 1))
1563                      (error "Invalid explicit condition ~s." condform)))
1564                  (if (and explicit-cond (not (eql c cond)))
1565                    (error "Can't use explicit condition and :? : ~s" condform)
1566                    (setq cond c)))))))
1567        (let* ((optypes (arm-instruction-template-operand-types template))
1568               (n (length optypes)))
1569          (unless (= n (length opvals))
1570            (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form))
1571          (set-field-value insn (byte 32 0) (arm-instruction-template-val template))
1572          (dotimes (i n)
1573            (let* ((optype (pop optypes))
1574                   (val (pop opvals)))
1575              (funcall (svref *arm-operand-parsers* optype) val insn)))
1576          (when cond
1577            (set-field-value insn (byte 4 28) cond))
1578          (emit-lap-instruction-element insn seg))))))
1579
1580;;; A label can only be emitted once.  Once it's been emitted, its pred/succ
1581;;; slots will be non-nil.
1582
1583(defun lap-label-emitted-p (lab)
1584  (not (null (lap-label-pred lab))))
1585
1586(defun %make-lap-label (name)
1587  (let* ((lab (ccl::alloc-dll-node *lap-label-freelist*)))
1588    (if lab
1589      (progn
1590        (setf (lap-label-address lab) nil
1591              (lap-label-refs lab) nil
1592              (lap-label-name lab) name)
1593        lab)
1594      (%%make-lap-label name))))
1595
1596(defun make-lap-label (name)
1597  (let* ((lab (%make-lap-label name)))
1598    (if (typep *lap-labels* 'hash-table)
1599      (setf (gethash name *lap-labels*) lab)
1600      (progn
1601        (push lab *lap-labels*)
1602        (if (> (length *lap-labels*) 255)
1603          (let* ((hash (make-hash-table :size 512 :test #'eq)))
1604            (dolist (l *lap-labels* (setq *lap-labels* hash))
1605              (setf (gethash (lap-label-name l) hash) l))))))
1606    lab))
1607
1608(defun find-lap-label (name)
1609  (if (typep *lap-labels* 'hash-table)
1610    (gethash name *lap-labels*)
1611    (car (member name *lap-labels* :test #'eq :key #'lap-label-name))))
1612
1613(defun lap-note-label-reference (labx insn type)
1614  (let* ((lab (or (find-lap-label labx)
1615                  (make-lap-label labx))))
1616    (push (cons insn type) (lap-label-refs lab))
1617    lab))
1618
1619(defun emit-lap-label (seg name)
1620  (let* ((lab (find-lap-label name)))
1621    (if  lab 
1622      (when (lap-label-emitted-p lab)
1623        (error "Label ~s: multiply defined." name))
1624      (setq lab (make-lap-label name)))
1625    (emit-lap-instruction-element lab seg)))
1626
1627(defmacro do-lap-labels ((lab &optional result) &body body)
1628  (let* ((thunk-name (gensym))
1629         (k (gensym))
1630         (xlab (gensym)))
1631    `(flet ((,thunk-name (,lab) ,@body))
1632      (if (listp *lap-labels*)
1633        (dolist (,xlab *lap-labels*)
1634          (,thunk-name ,xlab))
1635        (maphash #'(lambda (,k ,xlab)
1636                     (declare (ignore ,k))
1637                     (,thunk-name ,xlab))
1638                 *lap-labels*))
1639      ,result)))
1640
1641(defun section-size (seg)
1642  (let* ((last (ccl::dll-node-pred seg)))
1643    (if (eq last seg)                   ;empty
1644      0
1645      (the fixnum
1646        (+ (the fixnum (instruction-element-address last))
1647           (the fixnum (instruction-element-size last)))))))
1648                 
1649(defun set-element-addresses (start seg)
1650  (ccl::do-dll-nodes (element seg start)
1651    (setf (instruction-element-address element) start)
1652    (incf start (instruction-element-size element))))
1653
1654
1655           
1656   
1657 
1658(defun arm-finalize (seg &optional drained)
1659  (let* ((removed nil))
1660    (do-lap-labels (lab)
1661      (loop
1662        (when (dolist (ref (lap-label-refs lab) t)             
1663                (when (and (eq :b (cdr ref))
1664                           (eq lab (lap-instruction-succ (car ref))))
1665                  (ccl::remove-dll-node (car ref))
1666                  (setq removed t)
1667                  (setf (lap-label-refs lab)
1668                        (delete ref (lap-label-refs lab)))
1669                  (return)))
1670          (return))))
1671    (when removed
1672      (set-element-addresses 0 seg))
1673
1674   
1675    (unless drained
1676      (let* ((marker (make-lap-instruction nil))
1677             (code-count (make-lap-instruction nil)))
1678        (emit-lap-instruction-element marker seg)
1679        (emit-lap-instruction-element code-count seg)
1680        (set-field-value code-count (byte 32 0) (ash (section-size seg) -2))))
1681   
1682
1683         
1684   
1685    ;; Now fix up label references.  Recall that the PC value at some
1686    ;; point in program execution is 8 bytes beyond that point.
1687    (do-lap-labels (lab)
1688      (if (lap-label-emitted-p lab)
1689        (let* ((labaddr (lap-label-address lab)))
1690          (dolist (ref (lap-label-refs lab))
1691            (destructuring-bind (insn . reftype) ref
1692              (let* ((diff-in-bytes (- labaddr (+ 8 (lap-instruction-address insn)))))
1693                (case reftype
1694                  (:b (set-field-value insn (byte 24 0) (ash diff-in-bytes -2)))
1695                  ((:mem12 :fpmem)
1696                   (if (>= diff-in-bytes 0)
1697                     (set-field-value insn (byte 1 23) 1)
1698                     (setq diff-in-bytes (- diff-in-bytes)))
1699                   (when (> (integer-length diff-in-bytes) 12)
1700                     (error "PC-relative displacement can't be encoded."))
1701                   (if (eq reftype :fpmem)
1702                     (set-field-value insn (byte 8 0) (ash diff-in-bytes -2))
1703                     (set-field-value insn (byte 12 0) diff-in-bytes)))
1704                  (:offset
1705                   (set-field-value insn (byte 32 0)(1+ (ash (lap-instruction-address insn) (- arm::word-shift)))))
1706                  (t
1707                   (error "Label type ~s invalid or not yet supported."
1708                          reftype)))))))
1709        (if (lap-label-refs lab)
1710          (error "LAP label ~s was referenced but not defined." (lap-label-name lab)))))
1711    (ash (section-size seg) -2)))
1712
1713;;; We want to be able to write vinsn templates using a (mostly) LAP-like
1714;;; syntax, but ideally don't want to have to repeatedly expand those
1715;;; vinsn-definition-time-invariant elements of that syntax.
1716;;;
1717;;; For example, if DEST is a vinsn parameter and the vinsn body
1718;;; contains:
1719;;;
1720;;;   (ldr DEST (:@ rcontext (:$ arm::tcr.db-link)))
1721;;;
1722;;; then we know at definition time:
1723;;;  1) the opcode of the LDR instruction (obviously)
1724;;;  2) the fact that the LDR's :mem12 operand uses indexed
1725;;;     addressing with an immediate operand and no writeback
1726;;;  3) in this example, we also know the value of the RB field
1727;;;     and the value of the immediate operand, which happens
1728;;;     to be positive (setting the U bit).
1729;;;
1730;;;  We can apply this knowledge at definition time, and set
1731;;;  the appropriate bits (U, RN, IMM12) in the opcode.
1732;;;
1733;;;  We don't, of course, know the value of DEST at vinsn-definition
1734;;;  time, but we do know that it's the Nth vinsn parameter, so we
1735;;;  can turn this example into something like:
1736;;;
1737;;;  `(,(augmented-opcode-for-LDR) #(rd-field) #(index-of-DEST)
1738;;;
1739;;; This is defined here (rather than in the compiler backend) since
1740;;; it needs to know a lot about ARM instruction encoding.
1741
1742(defstruct (arm-vinsn-instruction (:constructor %make-arm-vinsn-instruction)
1743                                  (:conc-name avi-))
1744  head
1745  tail)
1746
1747(defun make-arm-vinsn-instruction (opcode)
1748  (let* ((head (list (cons (ldb (byte 16 16) opcode)
1749                           (ldb (byte 16 0) opcode)))))
1750    (%make-arm-vinsn-instruction :head head :tail head)))
1751
1752(defun add-avi-operand (instruction field-type value)
1753  (let* ((tail (avi-tail instruction)))
1754    (setf (avi-tail instruction)
1755          (cdr (rplacd tail (cons (cons field-type value) nil))))))
1756
1757(defun avi-opcode (avi)
1758  (car (avi-head avi)))
1759
1760
1761(defun set-avi-opcode-field (avi bytespec value)
1762  (let* ((opcode (avi-opcode avi)))
1763    (multiple-value-bind (high low)
1764        (set-opcode-values (car opcode) (cdr opcode) bytespec value)
1765      (declare (type (unsigned-byte 16) high low))
1766      (setf (car opcode) high
1767            (cdr opcode) low))
1768    value))
1769
1770(defun get-avi-opcode-field (avi bytespec)
1771  (let* ((opcode (avi-opcode avi)))
1772    (get-opcode-field (car opcode) (cdr opcode) bytespec)))
1773
1774
1775(eval-when (:compile-toplevel :load-toplevel :execute)
1776(defparameter *vinsn-field-types*
1777  #(:cond
1778    :negated-cond
1779    :rn
1780    :rd
1781    :rm
1782    :rs
1783    :alu-constant
1784    :shift-count                        ;shift type is always explicit
1785    :mem12-offset
1786    :mem8-offset
1787    :reglist-bit
1788    :uuoA
1789    :uuo-unary
1790    :uuoB
1791    :label
1792    :subprim
1793    :data-label
1794    :dd
1795    :dm
1796    :sd
1797    :sm
1798    :dn
1799    :sn
1800    :fpaddr-offset
1801    :uuoC
1802    :imm16
1803    :srcount
1804    :drcount
1805    :reglist
1806    :spentry
1807    :fplabel
1808    )))
1809
1810(defmacro encode-vinsn-field-type (name)
1811  (or (position name *vinsn-field-types*)
1812      (error "Unknown vinsn-field-type name ~s." name)))
1813
1814(defparameter *arm-vinsn-operand-parsers*
1815    #(vinsn-parse-rd-operand
1816      vinsn-parse-rn-operand
1817      vinsn-parse-shifter-operand
1818      vinsn-parse-m12-operand
1819      vinsn-parse-reglist-operand
1820      vinsn-parse-rnw-operand
1821      vinsn-parse-uuoa-operand
1822      vinsn-parse-uuo-unary-operand
1823      vinsn-parse-uuob-operand
1824      vinsn-parse-rm-operand
1825      vinsn-parse-b-operand
1826      vinsn-parse-subprim-operand
1827      vinsn-parse-m8-operand
1828      vinsn-parse-dd-operand
1829      vinsn-parse-dm-operand
1830      vinsn-parse-sd-operand
1831      vinsn-parse-sm-operand
1832      vinsn-parse-dn-operand
1833      vinsn-parse-sn-operand
1834      vinsn-parse-rde-operand
1835      vinsn-parse-rs-operand
1836      vinsn-parse-fpaddr-operand
1837      vinsn-parse-@rn-operand
1838      vinsn-parse-uuoc-operand
1839      vinsn-parse-fpux-operand
1840      vinsn-parse-imm16-operand
1841      vinsn-parse-srcount-operand
1842      vinsn-parse-drcount-operand
1843      vinsn-parse-spentry-operand
1844      ))
1845
1846(defun vinsn-arg-or-gpr (avi form vinsn-params encoded-type bytespec)
1847  (let* ((p (position form vinsn-params)))
1848    (cond (p
1849           (add-avi-operand avi encoded-type (list p))
1850           nil)
1851          (t           
1852           (set-avi-opcode-field avi bytespec (need-arm-gpr form))))))
1853
1854(defun vinsn-arg-or-dfpr (avi form vinsn-params encoded-type bytespec)
1855  (let* ((p (position form vinsn-params)))
1856    (cond (p
1857           (add-avi-operand avi encoded-type (list p))
1858           nil)
1859          (t           
1860           (set-avi-opcode-field avi bytespec (need-arm-dfpr form))))))
1861
1862(defun vinsn-arg-or-sfpr (avi form vinsn-params encoded-type top4 low1)
1863  (let* ((p (position form vinsn-params)))
1864    (cond (p
1865           (add-avi-operand avi encoded-type (list p))
1866           nil)
1867          (t
1868           (let* ((val (need-arm-sfpr form)))
1869             (set-avi-opcode-field avi top4 (ash val -1))
1870             (set-avi-opcode-field avi low1 (logand val 1)))))))
1871
1872(defun simplify-arm-vinsn-application (form params)
1873  (labels ((simplify-operand (op)
1874             (if (atom op)
1875               (if (typep form 'fixnum)
1876                 op
1877                 (if (constantp op)
1878                   (eval op)
1879                   (let* ((p (position op params)))
1880                     (if p
1881                       (list p)
1882                       (error "Unknown operand: ~s" op)))))
1883               (if (eq (car op) :apply)
1884                 `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op)))
1885                 (eval op)))))
1886    `(,(cadr form) ,@(mapcar #'simplify-operand (cddr form)))))
1887
1888(defun vinsn-arg-or-constant (avi form vinsn-params encoded-type bytespec)
1889  (let* ((p (position form vinsn-params)))
1890    (cond (p
1891           (add-avi-operand avi encoded-type (list p))
1892           nil)
1893          ((and (typep form 'keyword)
1894                (eql encoded-type (encode-vinsn-field-type :mem12-offset)))
1895           (add-avi-operand avi (encode-vinsn-field-type :data-label) form)
1896           nil)
1897          ((and (consp form) (eq (car form) :apply))
1898           (add-avi-operand avi encoded-type (simplify-arm-vinsn-application form vinsn-params))
1899           nil)
1900          (t
1901           (let* ((val (eval form)))
1902             (when bytespec
1903               (set-avi-opcode-field avi bytespec val))
1904             val)))))
1905
1906
1907
1908(defun vinsn-parse-rd-operand (avi value vinsn-params)
1909  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rd) (byte 4 12)))
1910
1911(defun vinsn-parse-rn-operand (avi value vinsn-params)
1912  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rn) (byte 4 16)))
1913
1914(defun vinsn-parse-shifter-operand (avi value vinsn-params)
1915  (if (atom value)
1916    (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1917    (ecase (car value)
1918      (:$
1919       (destructuring-bind (v) (cdr value)
1920         (let* ((val (vinsn-arg-or-constant avi v vinsn-params (encode-vinsn-field-type :alu-constant) nil)))
1921           (when val
1922             (let* ((constant (encode-arm-immediate val)))
1923               (if constant
1924                 (progn
1925                   (set-avi-opcode-field avi (byte 1 25) 1)
1926                   (set-avi-opcode-field avi (byte 12 0) constant))
1927                 (let* ((op (get-avi-opcode-field avi (byte 4 21)))
1928                        (newop nil))
1929                   (if (or (and (setq constant (encode-arm-immediate (lognot val)))
1930                                (setq newop (svref *equivalent-complemented-opcodes* op)))
1931                           (and (setq constant (encode-arm-immediate (- val)))
1932                                (setq newop (svref *equivalent-negated-opcodes* op))))
1933                     (progn
1934                       (set-avi-opcode-field avi (byte 1 25) 1)
1935                       (set-avi-opcode-field avi (byte 4 21) newop)
1936                       (set-avi-opcode-field avi (byte 12 0) constant))
1937                     
1938                     (error "Can't encode ARM constant ~s." value)))))))))
1939      (:rrx
1940       (destructuring-bind (rm) (cdr value)
1941         (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1942         (set-avi-opcode-field avi (byte 2 5) 3)))
1943      ((:lsl :lsr :asr :ror)
1944       (destructuring-bind (rm count) (cdr value)
1945         (set-avi-opcode-field avi (byte 2 5) (encode-arm-shift-type (car value)))
1946         (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1947         (cond
1948           ((atom count)
1949            (set-avi-opcode-field avi (byte 1 4) 1)
1950            (vinsn-arg-or-gpr avi count vinsn-params (encode-vinsn-field-type :rs) (byte 4 8)))
1951           (t
1952            (unless (eq (car count) :$)
1953              (error "Invalid shift count: ~s" count))
1954            (destructuring-bind (countval) (cdr count)
1955              (vinsn-arg-or-constant avi countval vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7))))))))))
1956
1957(defun vinsn-parse-m12-operand (avi value vinsn-params)
1958  (when (typep value 'keyword)
1959    (setq value `(:@ arm::pc (:$ ,value))))
1960  (destructuring-bind (op rn index) value     ; no (:@ reg) sugar
1961    (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16))
1962    (let* ((constant-index (and (consp index) (eq (car index) :$))))
1963      (unless constant-index
1964        (set-avi-opcode-field avi (byte 1 25) 1))
1965      (cond
1966        ((atom index)
1967         (vinsn-arg-or-gpr avi index vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)))
1968        (constant-index
1969         (destructuring-bind (constform) (cdr index)
1970           (let* ((constval
1971                   (vinsn-arg-or-constant avi constform vinsn-params (encode-vinsn-field-type :mem12-offset) nil)))
1972             (when constval
1973               (if (< constval 0)
1974                 (setq constval (- constval))
1975                 (set-avi-opcode-field avi (byte 1 23) 1))
1976               (unless (typep constval '(unsigned-byte 12))
1977                 (warn "constant offset too large : ~s" constval))
1978               (set-avi-opcode-field avi (byte 12 0) constval)))))
1979        ((eq (car index) :rrx)
1980         (destructuring-bind (rm) (cdr index)
1981           (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1982           (set-avi-opcode-field avi (byte 2 5) 3)))
1983        (t
1984         (destructuring-bind (shift-op rm shift-count) index
1985           (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1986           (set-avi-opcode-field avi (byte 2 5) (encode-arm-shift-type shift-op))
1987
1988           (unless (and (consp shift-count)
1989                        (eq (car shift-count) :$))
1990             (error "Invalid shift-count: ~s" shift-count))
1991           (destructuring-bind (shift-count-form) (cdr shift-count)
1992             (vinsn-arg-or-constant avi shift-count-form vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7))))))
1993      (let* ((opcode (avi-opcode avi)))
1994        (setf (car opcode)
1995              (the (unsigned-byte 16)
1996                (set-opcode-value-from-addressing-mode
1997                 (car opcode)
1998                 op
1999                 constant-index)))))))
2000
2001(defun vinsn-parse-reglist-operand (avi value vinsn-params)
2002  (if (eq (car value) :$)
2003    (let* ((mask (cadr value))
2004           (p (position mask vinsn-params)))
2005      (if p
2006        (add-avi-operand avi (encode-vinsn-field-type :reglist) (list p))
2007        (set-avi-opcode-field avi (byte 16 0) mask)))
2008    (dolist (r value)
2009      (let* ((p (position r vinsn-params)))
2010        (if p
2011          (add-avi-operand avi (encode-vinsn-field-type :reglist-bit) (list p))
2012          (let* ((bit (need-arm-gpr r)))
2013            (set-avi-opcode-field avi (byte 1 bit) 1)))))))
2014
2015(defun vinsn-parse-rnw-operand (avi value vinsn-params)
2016  (let* ((rn (if (atom value)
2017               value
2018               (destructuring-bind (marker reg) value
2019                 (if (eq marker :!)
2020                   (set-avi-opcode-field avi (byte 1 21) 1)
2021                   (error "Unrecognized writeback indicator in ~s." value))
2022                 reg))))
2023    (vinsn-arg-or-gpr avi rn vinsn-params  (encode-vinsn-field-type :rn) (byte 4 16))))
2024
2025(defun vinsn-parse-uuoA-operand (avi value vinsn-params)
2026  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :uuoA) (byte 4 8)))
2027
2028(defun vinsn-parse-uuo-unary-operand (avi value vinsn-params)
2029  (when (or (atom value)
2030          (not (eq (car value) :$)))
2031    (error "Invalid constant syntax in ~s." value))
2032  (destructuring-bind (valform) (cdr value)
2033    (vinsn-arg-or-constant avi valform vinsn-params (encode-vinsn-field-type :uuo-unary) (byte 8 12))))
2034
2035(defun vinsn-parse-uuoB-operand (avi value vinsn-params)
2036  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :uuoB) (byte 4 12)))
2037
2038(defun vinsn-parse-uuoC-operand (avi value vinsn-params)
2039  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :uuoC) (byte 4 16)))
2040
2041(defun vinsn-parse-fpux-operand (avi value vinsn-params)
2042  (declare (ignore vinsn-params))
2043  (let* ((regno (if (typep value '(unsigned-byte 4))
2044                  value
2045                  (ecase value
2046                    (:fpsid 0)
2047                    (:fpscr 1)
2048                    (:fpexc 8)))))
2049    (set-avi-opcode-field avi (byte 4 16) regno)))
2050
2051(defun vinsn-parse-rm-operand (avi value vinsn-params)
2052  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)))
2053
2054(defun vinsn-parse-b-operand (avi value vinsn-params)
2055  ;; Pretty much has to be a param or a local label what else would we b to ?
2056  (let* ((p (position value vinsn-params)))
2057    (cond (p
2058           (add-avi-operand avi (encode-vinsn-field-type :label) (list p)))
2059          ((typep value 'keyword)
2060           (add-avi-operand avi (encode-vinsn-field-type :label) value))
2061          (t
2062           (error "Unknown branch target: ~s." value)))))
2063
2064(defun vinsn-parse-subprim-operand (avi value vinsn-params)
2065  (let* ((p (position value vinsn-params))
2066         (addr nil))
2067    (cond (p
2068           (add-avi-operand avi (encode-vinsn-field-type :subprim) (list p)))
2069          ((setq addr (arm-subprimitive-offset value))
2070           (add-avi-operand avi (encode-vinsn-field-type :subprim) addr))
2071          ((arm-subprimitive-name value)
2072           (add-avi-operand avi (encode-vinsn-field-type :subprim) value)) 
2073          (t
2074           (error "Unknown subprimitive name or address: ~s." value)))))
2075
2076(defun vinsn-parse-spentry-operand (avi value vinsn-params)
2077  (let* ((p (position value vinsn-params))
2078         (addr nil))
2079    (cond (p
2080           (add-avi-operand avi (encode-vinsn-field-type :spentry) (list p)))
2081          ((setq addr (arm-subprimitive-offset value))
2082           (add-avi-operand avi (encode-vinsn-field-type :spentry) addr))
2083          ((arm-subprimitive-name value)
2084           (add-avi-operand avi (encode-vinsn-field-type :spentry) value)) 
2085          (t
2086           (error "Unknown subprimitive name or address: ~s." value)))))
2087
2088(defun vinsn-parse-m8-operand (avi value vinsn-params)
2089  (if (atom value)
2090    (error "Invalid memory operand ~s." value)
2091    (destructuring-bind (mode rn index) value
2092      (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16))
2093      (let* ((constant-index (and (consp index) (eq (car index) :$))))
2094        (when constant-index
2095          (set-avi-opcode-field avi (byte 1 22) 1))
2096        (cond ((atom index)
2097               (vinsn-arg-or-gpr avi index vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)))
2098              (constant-index
2099               (destructuring-bind (constform) (cdr index)
2100                 (let* ((constval
2101                         (vinsn-arg-or-constant avi constform vinsn-params (encode-vinsn-field-type :mem8-offset) nil)))
2102                   (when constval
2103                     (if (< constval 0)
2104                       (setq constval (- constval))
2105                       (set-avi-opcode-field avi (byte 1 23) 1))
2106                     (unless (typep constval '(unsigned-byte 8))
2107                       (warn "constant offset too large : ~s" constval))
2108                     (set-avi-opcode-field avi (byte 4 0) (ldb (byte 4 0) constval))
2109                     (set-avi-opcode-field avi (byte 4 8) (ldb (byte 4 4) constval))))))
2110              ((eq (car index) :rrx)
2111               (destructuring-bind (rm) (cdr index)
2112                 (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
2113                 (set-avi-opcode-field avi (byte 2 5) 3)))
2114              (t
2115               (destructuring-bind (shift-op rm shift-count) index
2116                 (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
2117                 (set-avi-opcode-field avi (byte 2 5) (encode-arm-shift-type shift-op))
2118                 (unless (and (consp shift-count)
2119                              (eq (car shift-count) :$))
2120                   (error "Invalid shift-count: ~s" shift-count))
2121                 (destructuring-bind (shift-count-form) (cdr shift-count)
2122                   (vinsn-arg-or-constant avi shift-count-form vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7))))))
2123        (setf (car (avi-opcode avi))
2124              (the (unsigned-byte 16)
2125              (set-opcode-value-from-addressing-mode (car (avi-opcode avi)) mode constant-index)))))))
2126
2127
2128
2129(defun vinsn-parse-dd-operand (avi value vinsn-params)
2130  (vinsn-arg-or-dfpr avi value vinsn-params (encode-vinsn-field-type :dd) (byte 4 12)))
2131
2132(defun vinsn-parse-dm-operand (avi value vinsn-params)
2133  (vinsn-arg-or-dfpr avi value vinsn-params (encode-vinsn-field-type :dm) (byte 4 0)))
2134
2135(defun vinsn-parse-sd-operand (avi value vinsn-params)
2136  (vinsn-arg-or-sfpr avi value vinsn-params (encode-vinsn-field-type :sd) (byte 4 12) (byte 1 22)))
2137
2138(defun vinsn-parse-sm-operand (avi value vinsn-params)
2139  (vinsn-arg-or-sfpr avi value vinsn-params (encode-vinsn-field-type :sm) (byte 4 0) (byte 1 5)))
2140
2141(defun vinsn-parse-dn-operand (avi value vinsn-params)
2142  (vinsn-arg-or-dfpr avi value vinsn-params (encode-vinsn-field-type :dn) (byte 4 16)))
2143
2144(defun vinsn-parse-sn-operand (avi value vinsn-params)
2145  (vinsn-arg-or-sfpr avi value vinsn-params (encode-vinsn-field-type :sn) (byte 4 16) (byte 1 7)))
2146
2147(defun vinsn-parse-rde-operand (avi value vinsn-params)
2148  (let* ((val (get-arm-gpr value)))
2149    (when (and val (oddp val))
2150      (error "Register ~s must be even-numbered." value)))
2151  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rd) (byte 4 12)))
2152
2153(defun vinsn-parse-rs-operand (avi value vinsn-params)
2154  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rs) (byte 4 8)))
2155
2156(defun vinsn-parse-fpaddr-operand (avi value vinsn-params)
2157  (if (and (consp value) (eq (car value) :=))
2158    (destructuring-bind (label) (cdr value)
2159      (set-avi-opcode-field avi (byte 4 16) arm::pc)
2160      (let* ((p (position value vinsn-params)))
2161        (cond (p
2162               (add-avi-operand avi (encode-vinsn-field-type :fplabel) (list p)))
2163              ((typep label 'keyword)
2164               (add-avi-operand avi (encode-vinsn-field-type :fplabel) label))
2165              (t (error "Unknown label: ~s" label)))))
2166    (destructuring-bind (op rn offset) value
2167      (unless (eq op :@) (error "Bad FP address operand: ~s." value))
2168      (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16))
2169      (destructuring-bind (marker offform) offset
2170        (unless (eq marker :$) (error "Bad FP offset: ~s" offset))
2171        (let* ((offval (vinsn-arg-or-constant avi offform vinsn-params (encode-vinsn-field-type :fpaddr-offset) nil)))
2172          (when offval
2173            (if (< offval 0)
2174              (setq offval (- offval))
2175              (set-avi-opcode-field avi (byte 1 23) 1))
2176            (when (logtest 3 offval)
2177              (error "Memory offset ~s must be a multiple of 4." offval))
2178            (set-avi-opcode-field avi (byte 8 0) (ash offval -2))))))))
2179
2180(defun vinsn-parse-imm16-operand (avi value vinsn-params)
2181  (unless (and (consp value)
2182               (eq (car value) :$)
2183               (consp (cdr value))
2184               (null (cddr value)))
2185    (error "Bad imm16 constant operand syntax: ~s." value))
2186  (let* ((val (vinsn-arg-or-constant avi (cadr value) vinsn-params (encode-vinsn-field-type :imm16) nil)))
2187    (when val
2188      (set-avi-opcode-field avi (byte 12 0) (ldb (byte 12 0) val))
2189      (set-avi-opcode-field avi (byte 4 16) (ldb (byte 4 12) val)))))
2190
2191(defun vinsn-parse-srcount-operand (avi value vinsn-params)
2192  (let* ((val (vinsn-arg-or-constant avi value vinsn-params (encode-vinsn-field-type :srcount) nil)))
2193    (when val
2194      (check-type val (integer 1 32))
2195      (set-avi-opcode-field avi (byte 8 0) val))))
2196
2197(defun vinsn-parse-drcount-operand (avi value vinsn-params)
2198  (let* ((val (vinsn-arg-or-constant avi value vinsn-params (encode-vinsn-field-type :drcount) nil)))
2199    (when val
2200      (check-type val (integer 1 32))
2201      (set-avi-opcode-field avi (byte 7 1) val))))
2202
2203(defun vinsn-simplify-instruction (form vinsn-params)
2204  (destructuring-bind (name . opvals) form
2205    (case name
2206      ((:code :data) form)
2207      (:word (destructuring-bind (val) opvals
2208               (let* ((p (position val vinsn-params)))
2209                 (list name (if p (list p) (eval val))))))
2210      (t
2211       (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name)
2212         (unless template
2213           (error "Unknown ARM instruction - ~s" form))
2214         (let* ((cond-indicator (and (consp (car opvals))
2215                                     (caar opvals)))
2216                (avi (make-arm-vinsn-instruction (arm-instruction-template-val template))))
2217           (when (or (eq cond-indicator :?)
2218                     (eq cond-indicator :~))
2219             (let* ((condform (pop opvals)))
2220               (destructuring-bind (cond-name) (cdr condform)
2221                 (let* ((p (position cond-name vinsn-params)))
2222                   (if p
2223                     (if explicit-cond
2224                       (error "Can't use ~s with explicit condition name." condform)
2225                       (progn
2226                         (add-avi-operand avi (if (eq cond-indicator :?)
2227                                                (encode-vinsn-field-type :cond)
2228                                                (encode-vinsn-field-type :negated-cond))
2229                                          (list p))
2230                         (setq cond nil)))
2231                     (let* ((c (need-arm-condition-name cond-name)))
2232                       (when (eq cond-indicator :~)
2233                         (if (< c 14)
2234                           (setq c (logxor c 1))
2235                           (error "Invalid explicit condition ~s." condform)))
2236                       (if (and explicit-cond (not (eql c cond)))
2237                         (error "Can't use explicit condition and :? : ~s" condform)
2238                         (setq cond c))))))))
2239           (let* ((optypes (arm-instruction-template-operand-types template))
2240                  (n (length optypes)))
2241             (unless (= n (length opvals))
2242               (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form))
2243             (dotimes (i n)
2244               (let* ((optype (pop optypes))
2245                      (opval (pop opvals)))
2246                 (funcall (svref *arm-vinsn-operand-parsers* optype)
2247                          avi opval vinsn-params)))
2248             (when cond
2249               (set-avi-opcode-field avi (byte 4 28) cond))
2250             (avi-head avi))))))))
2251         
2252
2253(defparameter *arm-vinsn-insert-functions*
2254  #(vinsn-insert-cond-operand
2255    vinsn-insert-negated-cond-operand
2256    vinsn-insert-rn-operand
2257    vinsn-insert-rd-operand
2258    vinsn-insert-rm-operand
2259    vinsn-insert-rs-operand
2260    vinsn-insert-alu-constant-operand
2261    vinsn-insert-shift-count-operand                        ;shift type is always explicit
2262    vinsn-insert-mem12-offset-operand
2263    vinsn-insert-mem8-offset-operand
2264    vinsn-insert-reglist-bit-operand
2265    vinsn-insert-uuoA-operand
2266    vinsn-insert-uuo-unary-operand
2267    vinsn-insert-uuoB-operand
2268    vinsn-insert-label-operand
2269    vinsn-insert-subprim-operand
2270    vinsn-insert-data-label-operand
2271    vinsn-insert-dd-operand
2272    vinsn-insert-dm-operand
2273    vinsn-insert-sd-operand
2274    vinsn-insert-sm-operand
2275    vinsn-insert-dn-operand
2276    vinsn-insert-sn-operand
2277    vinsn-insert-fpaddr-offset-operand
2278    vinsn-insert-uuoc-operand
2279    vinsn-insert-imm16-operand
2280    vinsn-insert-srcount-operand
2281    vinsn-insert-drcount-operand
2282    vinsn-insert-reglist-operand
2283    vinsn-insert-spentry-operand
2284    vinsn-insert-fplabel-operand
2285    ))
2286
2287(defun vinsn-insert-cond-operand (instruction value)
2288  (set-field-value instruction (byte 4 28) value))
2289
2290(defun vinsn-insert-negated-cond-operand (instruction value)
2291  (set-field-value instruction (byte 4 28) (logxor value 1)))
2292
2293(defun vinsn-insert-rn-operand (instruction value)
2294  (set-field-value instruction (byte 4 16) value))
2295
2296(defun vinsn-insert-rd-operand (instruction value)
2297  (set-field-value instruction (byte 4 12) value))
2298
2299(defun vinsn-insert-rm-operand (instruction value)
2300  (set-field-value instruction (byte 4 0) value))
2301
2302(defun vinsn-insert-rs-operand (instruction value)
2303  (set-field-value instruction (byte 4 8) value))
2304
2305(defun vinsn-insert-alu-constant-operand (instruction value)
2306  (insert-shifter-constant value instruction))
2307
2308(defun vinsn-insert-shift-count-operand (instruction value)
2309  (set-field-value instruction (byte 5 7) value))
2310
2311(defun vinsn-insert-mem12-offset-operand (instruction value)
2312  (if (typep value 'lap-label)
2313    (lap-note-label-reference value instruction :mem12)
2314    (progn
2315      (if (< value 0)
2316        (setq value (- value))
2317        (set-field-value instruction (byte 1 23) 1))
2318      (set-field-value instruction (byte 12 0) value))))
2319
2320(defun vinsn-insert-mem8-offset-operand (instruction value) 
2321  (if (< value 0)
2322    (setq value (- value))
2323    (set-field-value instruction (byte 1 23) 1))
2324  (set-field-value instruction (byte 4 8) (ldb (byte 4 4) value))
2325  (set-field-value instruction (byte 4 0) (ldb (byte 4 0) value)))
2326
2327(defun vinsn-insert-reglist-bit-operand (instruction value)
2328  (set-field-value instruction (byte 1 value) 1))
2329
2330(defun vinsn-insert-uuoA-operand (instruction value)
2331  (set-field-value instruction (byte 4 8) value))
2332
2333(defun vinsn-insert-uuo-unary-operand (instruction value)
2334  (set-field-value instruction (byte 8 12) value))
2335
2336(defun vinsn-insert-uuoB-operand (instruction value)
2337  (set-field-value instruction (byte 4 12) value))
2338
2339(defun vinsn-insert-uuoC-operand (instruction value)
2340  (set-field-value instruction (byte 4 16) value))
2341
2342(defun vinsn-insert-label-operand (instruction value)
2343  (let* ((label (etypecase value
2344                  (cons (or (find-lap-label value)
2345                            (error "No LAP label for ~s." (car value))))
2346                  (lap-label value)
2347                  (ccl::vinsn-label
2348                   (or (find-lap-label value)
2349                       (make-lap-label value))))))
2350    (push (cons instruction :b) (lap-label-refs label))))
2351
2352(defun vinsn-insert-fplabel-operand (instruction value)
2353  (let* ((label (etypecase value
2354                  (cons (or (find-lap-label value)
2355                            (error "No LAP label for ~s." (car value))))
2356                  (lap-label value)
2357                  (ccl::vinsn-label
2358                   (or (find-lap-label value)
2359                       (make-lap-label value))))))
2360    (push (cons instruction :fpmem) (lap-label-refs label))))
2361
2362(defun vinsn-insert-subprim-operand (instruction value)
2363  (declare (ignorable instruction value))
2364  (ccl::compiler-bug "Obsolete SUBPRIM vinsn operand."))
2365
2366(defun vinsn-insert-spentry-operand (instruction value)
2367  (unless (and (typep value 'fixnum)
2368               (>= value arm::tcr.sptab)
2369               (< value (+ arm::tcr.sptab (* 256 4)))
2370               (not (logtest value 3)))
2371    (error "Bad subprim index: ~s" value))
2372  (set-field-value instruction (byte 12 0) value))
2373
2374
2375
2376(defun vinsn-insert-data-label-operand (instruction value)
2377  (let* ((label (if (typep value 'lap-label) value (find-lap-label value))))
2378    (unless label
2379      (error "Mystery data label: ~s" value))
2380    (push (cons instruction :mem12) (lap-label-refs label))))
2381
2382
2383
2384(defun vinsn-insert-dd-operand (instruction value)
2385  (set-field-value instruction (byte 4 12) value) )
2386
2387(defun vinsn-insert-dm-operand (instruction value)
2388  (set-field-value instruction (byte 4 0) value))
2389
2390(defun vinsn-insert-sd-operand (instruction value)
2391  (set-field-value instruction (byte 4 12) (ash value -1))
2392  (set-field-value instruction (byte 1 22) (logand value 1)))
2393
2394(defun vinsn-insert-sm-operand (instruction value)
2395  (set-field-value instruction (byte 4 0) (ash value -1))
2396  (set-field-value instruction (byte 1 5) (logand value 1)))
2397
2398(defun vinsn-insert-dn-operand (instruction value)
2399  (set-field-value instruction (byte 4 16) value))
2400
2401(defun vinsn-insert-sn-operand (instruction value)
2402  (set-field-value instruction (byte 4 16) (ash value -1))
2403  (set-field-value instruction (byte 1 7) (logand value 1)))
2404
2405(defun vinsn-insert-fpaddr-offset-operand (instruction value)
2406  (if (< value 0)
2407    (setq value (- value))
2408    (set-field-value instruction (byte 1 23) 1))
2409  (set-field-value instruction (byte 8 0) (ash value -2)))
2410
2411(defun vinsn-insert-imm16-operand (instruction value)
2412  (set-field-value instruction (byte 12 0) (ldb (byte 12 0) value))
2413  (set-field-value instruction (byte 4 16) (ldb (byte 4 12) value)))
2414
2415(defun vinsn-insert-srcount-operand (instruction value)
2416  (set-field-value instruction (byte 8 0) value))
2417
2418(defun vinsn-insert-drcount-operand (instruction value)
2419  (set-field-value instruction (byte 7 1) value)) 
2420
2421(defun vinsn-insert-reglist-operand (instruction value)
2422  (set-field-value instruction (byte 16 0) value))
2423
2424
2425(provide "ARM-ASM")
Note: See TracBrowser for help on using the repository browser.