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

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

Add uuo-kernel-service; fix smull, smulls.

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