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

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

Fix some FP instructions' masks so that the disassembler will
recognize those instructions properly.

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