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

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

Propagate r14113 from ARM branch to trunk.

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