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

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

Define ISB, DSB, DMB instructions. (A prerequisite to actually using
those instructions as needed.)

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