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

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

More UUOs (for N-dimensional AREF.)
vinsns for N-d aref; backend support for N-d aref.
Careful doing ASET to DOUBLE-FLOAT vectors.

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