source: branches/arm/compiler/ARM/arm-asm.lisp @ 13807

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

Define some more FP instructions, fix some typos.

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