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

Last change on this file since 14033 was 14033, checked in by gb, 11 years ago

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