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

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

And we need to continue to tweak those mechanisms.

File size: 54.8 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                                      ("cc" . 2) ("hs" . 2) ("cs" . 3) ("lo" . 3)
25                                      ("mi" . 4) ("pl" . 5)
26                                      ("vs" . 6) ("vc" . 7)
27                                      ("hi" . 8) ("ls" . 9)
28                                      ("ge" . 10) ("lt" . 11)
29                                      ("gt" . 12) ("le" . 13)
30                                      ("al" . 14)))
31
32
33
34(defun lookup-arm-condition-name (name)
35  (cdr (assoc name *arm-condition-names* :test #'string-equal)))
36
37(defun lookup-arm-condition-value (val)
38  (car (rassoc val *arm-condition-names* :test #'eq)))
39
40(defun need-arm-condition-name (name)
41  (or (lookup-arm-condition-name name)
42      (error "Unknown ARM condition name ~s." name)))
43
44(defvar *arm-constants* ())
45(defvar *lap-labels* ())
46(defvar *called-subprim-jmp-labels* ())
47
48
49(defun arm-subprimitive-address (x)
50  (if (and x (or (symbolp x) (stringp x)))
51    (let* ((info (find x arm::*arm-subprims* :test #'string-equal :key #'ccl::subprimitive-info-name)))
52      (when info
53        (ccl::subprimitive-info-offset info)))))
54
55(defun arm-subprimitive-name (addr)
56  (let* ((info (find addr arm::*arm-subprims* :key #'ccl::subprimitive-info-offset)))
57    (when info
58      (string (ccl::subprimitive-info-name info)))))
59
60
61(defun arm-constant-index (form)
62  (let* ((idx (or (assoc form *arm-constants* :test 'equal)
63                  (let* ((n (length *arm-constants*)))
64                    (push (cons form n) *arm-constants*)
65                    n))))
66    (+ (ash (+ idx 2) arm::word-shift)  ; skip entrypoint, codevector
67       arm::misc-data-offset)))
68
69           
70
71(defun need-constant (form)
72  (if (ccl::quoted-form-p form)
73    (let* ((quoted (ccl::nx-unquote form)))
74      (if (null quoted)
75        arm::canonical-nil-value
76        (if (typep quoted '(signed-byte 30))
77          (ash quoted arm::fixnumshift)
78          (arm-constant-index quoted))))
79    (progn
80      (unless (and (consp form) (eq (keywordize (car form)) :$))
81        (error "Invalid constant syntax in ~s" form))
82      (destructuring-bind (val) (cdr form)
83        (eval val)))))
84               
85               
86(defstruct arm-instruction-template
87  name
88  ordinal                               ;if we need this
89  val
90  (flags 0)
91  operand-types
92  mask-list)
93
94(eval-when (:compile-toplevel :load-toplevel :execute)
95
96(ccl::defenum (:prefix "ARM-OPERAND-TYPE-")
97  rd                                    ; destination register in bits 12:15
98  rn                                    ; unshifted source/base reg in 16:19
99  shifter                               ; composite operand for ALU ops
100  mem12                                 ; 12-bit address for LDR/STR/LDRB/STB
101  reglist
102  rnw                                   ; rn, with optional writeback.
103  uuoA                                  ; GPR in UUO bits 8:11
104  uuo-unary                             ; constant in UUO bits 12:15
105  uuoB                                  ; GPR in UUO bits 12:15
106  rm
107  b
108  subprim
109  mem8
110)
111
112(defparameter *arm-operand-type-names*
113  `((:rd . ,arm-operand-type-rd)
114    (:rn . ,arm-operand-type-rn)
115    (:shifter . ,arm-operand-type-shifter)
116    (:mem12 . ,arm-operand-type-mem12)
117    (:reglist . ,arm-operand-type-reglist)
118    (:rnw . ,arm-operand-type-rnw)
119    (:uuoA . ,arm-operand-type-uuoA)
120    (:uuo-unary . ,arm-operand-type-uuo-unary)
121    (:uuoB . ,arm-operand-type-uuoB)
122    (:rm . ,arm-operand-type-rm)
123    (:b . ,arm-operand-type-b)
124    (:subprim . ,arm-operand-type-subprim)
125    (:mem8 . ,arm-operand-type-mem8)
126    ))
127
128
129
130
131(defun encode-arm-operand-type (name)
132  (or (cdr (assoc name *arm-operand-type-names* :test #'eq))
133      (error "Unknown ARM operand type name ~s." name)))
134
135(ccl::defenum (:prefix "ARM-INSTRUCTION-FLAG-")
136  non-conditional                       ;doesn't use standard condition field
137  prefer-separate-cond
138  )
139
140(defparameter *arm-instruction-flag-names*
141  `((:non-conditional . ,arm-instruction-flag-non-conditional)
142    (:prefer-separate-cond . ,arm-instruction-flag-prefer-separate-cond)
143    ))
144
145(defun %encode-arm-instruction-flag (name)
146  (flet ((encode-one-instruction-type (name)
147           (ash 1 (or (cdr (assoc name *arm-instruction-flag-names* :test #'eq))
148                      (error "Unknown ARM instruction type: ~s" name)))))
149    (if name
150      (if (atom name)
151        (encode-one-instruction-type name)
152        (let* ((mask 0))
153          (dolist (n name mask)
154            (setq mask (logior mask (encode-one-instruction-type n))))))
155      0)))
156)
157
158(defmacro encode-arm-instruction-flag (name)
159  (%encode-arm-instruction-flag name))
160
161(defvar *arm-instruction-ordinals* (make-hash-table :test #'equalp))
162
163
164
165(defun %define-arm-instruction (name value mask-list flags operand-types)
166  (make-arm-instruction-template :name name
167                                    :val value
168                                    :ordinal nil
169                                    :mask-list mask-list
170                                    :flags (or flags 0)
171                                    :operand-types operand-types))
172
173(defmacro define-arm-instruction (name operand-type-names value mask-list flag-names)
174  `(%define-arm-instruction ,(string-downcase name) ,value ',mask-list ,(%encode-arm-instruction-flag flag-names) ',(mapcar #'encode-arm-operand-type operand-type-names) ))
175
176(defparameter *arm-instruction-table*
177  (vector
178
179;;; UUOs.
180
181;;; Nullary UUOs
182   (define-arm-instruction uuo-alloc-trap ()
183     #x07f000f0
184     #x0fffffff
185     (:prefer-separate-cond))
186   (define-arm-instruction uuo-error-wrong-nargs ()
187     #x07f001f0
188     #x0fffffff
189     (:prefer-separate-cond))
190   (define-arm-instruction uuo-gc-trap ()
191     #x07f002f0
192     #x0fffffff 
193     (:prefer-separate-cond))
194   (define-arm-instruction uuo-debug-trap ()
195     #x07f003f0
196     #x0fffffff 
197     (:prefer-separate-cond))
198   (define-arm-instruction uuo-interrupt-now ()
199     #x07f004f0
200     #x0fffffff
201     (:prefer-separate-cond))
202   (define-arm-instruction uuo-suspend-now ()
203     #x07f005f0
204     #x0fffffff
205     (:prefer-separate-cond))
206
207;;; Misc format
208   (define-arm-instruction uuo-error-reg-not-lisptag (:uuoA :uuo-unary)
209     #x07f000f2
210     #x0ff000ff
211     (:prefer-separate-cond))
212   (define-arm-instruction uuo-error-reg-not-fulltag (:uuoA :uuo-unary)
213     #x07f000f3
214     #x0ff000ff
215     (:prefer-separate-cond))
216   (define-arm-instruction uuo-error-reg-not-xtype (:uuoA :uuo-unary)
217     #x07f000f4
218     #x0ff000ff
219     (:prefer-separate-cond))
220   (define-arm-instruction uuo-cerror-reg-not-lisptag (:uuoA :uuo-unary)
221     #x07f000fa
222     #x0ff000ff
223     (:prefer-separate-cond))
224   (define-arm-instruction uuo-cerror-reg-not-fulltag (:uuoA :uuo-unary)
225     #x07f000fb
226     #x0ff000ff
227     (:prefer-separate-cond))
228   (define-arm-instruction uuo-cerror-reg-not-xtype (:uuoA :uuo-unary)
229     #x07f000fc
230     #x0ff000ff
231     (:prefer-separate-cond))
232
233;;; Unary UUOs
234   (define-arm-instruction uuo-error-unbound (:uuoA)
235     #x07f000f1
236     #x0ffff0ff
237     (:prefer-separate-cond))
238   (define-arm-instruction uuo-cerror-unbound (:uuoA)
239     #x07f010f1
240     #x0ffff0ff
241     (:prefer-separate-cond))
242   (define-arm-instruction uuo-error-not-callable (:uuoA)
243     #x07f020f1
244     #x0ffff0ff
245     (:prefer-separate-cond))
246   (define-arm-instruction uuo-tlb-too-small (:uuoA)
247     #x07f030f1
248     #x0ffff0ff
249     (:prefer-separate-cond))
250   (define-arm-instruction uuo-error-no-throw-tag (:uuoA)
251     #x07f040f1
252     #x0ffff0ff
253     (:prefer-separate-cond))
254
255;;; Binary UUOs
256   (define-arm-instruction uuo-error-vector-bounds (:uuoA :uuoB)
257     #x07f000ff
258     #x0fff00ff
259     (:prefer-separate-cond))
260   (define-arm-instruction uuo-error-array-bounds (:uuoA :uuoB)
261     #x07f100ff
262     #x0fff00ff
263     (:prefer-separate-cond))
264
265
266   (define-arm-instruction and (:rd :rn :shifter)
267     #x00000000
268     ((#x02000000 . #x0ff00000)
269      (#x00000000 . #x0ff00010)
270      (#x00000010 . #x0ff00090))
271     ())
272   (define-arm-instruction ands (:rd :rn :shifter)
273     #x00100000
274     ((#x03000000 . #x0ff00000)
275      (#x01000000 . #x0ff00010)
276      (#x01000010 . #x0ff00090))
277     ())
278   (define-arm-instruction eor (:rd :rn :shifter)
279     #x00200000
280     ((#x02200000 . #x0ff00000)
281      (#x00200000 . #x0ff00010)
282      (#x00200010 . #x0ff00090))
283     ())
284   (define-arm-instruction eors (:rd :rn :shifter)
285     #x00300000
286     ((#x02300000 . #x0ff00000)
287      (#x00300000 . #x0ff00010)
288      (#x00300010 . #x0ff00090))
289     ())
290   (define-arm-instruction sub (:rd :rn :shifter)
291     #x00400000
292     ((#x02400000 . #x0ff00000)
293      (#x00400000 . #x0ff00010)
294      (#x00400010 . #x0ff00090))
295     ())
296   (define-arm-instruction subs (:rd :rn :shifter)
297     #x00500000
298     ((#x02500000 . #x0ff00000)
299      (#x00500000 . #x0ff00010)
300      (#x00500010 . #x0ff00090))
301     ())
302   (define-arm-instruction rsb (:rd :rn :shifter)
303     #x00600000
304     ((#x02600000 . #x0ff00000)
305      (#x00600000 . #x0ff00010)
306      (#x00600010 . #x0ff00090))
307     ())
308   (define-arm-instruction rsbs (:rd :rn :shifter)
309     #x00700000
310     ((#x02700000 . #x0ff00000)
311      (#x00700000 . #x0ff00010)
312      (#x00700010 . #x0ff00090))
313     ())   
314   (define-arm-instruction add (:rd :rn :shifter)
315     #x00800000
316     ((#x02800000 . #x0ff00000)
317      (#x00800000 . #x0ff00010)
318      (#x00800010 . #x0ff00090))
319     ())
320   (define-arm-instruction adds (:rd :rn :shifter)
321     #x00900000
322     ((#x02900000 . #x0ff00000)
323      (#x00900000 . #x0ff00010)
324      (#x00900010 . #x0ff00090))
325     ())
326
327   (define-arm-instruction adc (:rd :rn :shifter)
328     #x00a00000
329     ((#x02a00000 . #x0ff00000)
330      (#x00a00000 . #x0ff00010)
331      (#x00a00010 . #x0ff00090))
332     ())
333   (define-arm-instruction adcs (:rd :rn :shifter)
334     #x00b00000
335     ((#x02b00000 . #x0ff00000)
336      (#x00b00000 . #x0ff00010)
337      (#x00b00010 . #x0ff00090))
338     ())
339   (define-arm-instruction sbc (:rd :rn :shifter)
340     #x00c00000
341     ((#x02c00000 . #x0ff00000)
342      (#x00c00000 . #x0ff00010)
343      (#x00c00010 . #x0ff00090))
344     ())
345   (define-arm-instruction sbcs (:rd :rn :shifter)
346     #x00d00000
347     ((#x02d00000 . #x0ff00000)
348      (#x00d00000 . #x0ff00010)
349      (#x00d00010 . #x0ff00090))
350     ())
351   (define-arm-instruction rsc (:rd :rn :shifter)
352     #x00e00000
353     ((#x02e00000 . #x0ff00000)
354      (#x00e00000 . #x0ff00010)
355      (#x00e00010 . #x0ff00090))
356     ())
357   (define-arm-instruction rscs (:rd :rn :shifter)
358     #x00e00000
359     ((#x02e00000 . #x0ff00000)
360      (#x00e00000 . #x0ff00010)
361      (#x00e00010 . #x0ff00090))
362     ())
363   (define-arm-instruction tst (:rd :shifter)
364     #x01100000
365     ((#x03100000 . #x0ff00000)
366      (#x01100000 . #x0ff00010)
367      (#x01100010 . #x0ff00090))
368     ())
369   (define-arm-instruction tsts (:rd :shifter)
370     #x01100000
371     ((#x03100000 . #x0ff00000)
372      (#x01100000 . #x0ff00010)
373      (#x01100010 . #x0ff00090))
374     ())
375   (define-arm-instruction orr (:rd :rn :shifter)
376     #x01800000
377     ((#x03800000 . #x0ff00000)
378      (#x01800000 . #x0ff00010)
379      (#x01800010 . #x0ff00090))
380     ())
381   (define-arm-instruction orrs (:rd :rn :shifter)
382     #x01900000
383     ((#x03900000 . #x0ff00000)
384      (#x01900000 . #x0ff00010)
385      (#x01900010 . #x0ff00090))
386     ())
387   (define-arm-instruction bic (:rd :rn :shifter)
388     #x01c00000
389     ((#x03c00000 . #x0ff00000)
390      (#x01c00000 . #x0ff00010)
391      (#x01c00010 . #x0ff00090))
392     ())
393   (define-arm-instruction bics (:rd :rn :shifter)
394     #x01d00000
395     ((#x03d00000 . #x0ff00000)
396      (#x01d00000 . #x0ff00010)
397      (#x01d00010 . #x0ff00090))
398     ())
399   (define-arm-instruction cmp (:rd :shifter)
400     #x01500000
401     ((#x03500000 . #x0ff00000)
402      (#x01500000 . #x0ff00010)
403      (#x01500010 . #x0ff00090))
404     ())
405   (define-arm-instruction cmps (:rd :shifter)
406     #x01500000
407     ((#x03500000 . #x0ff00000)
408      (#x01500000 . #x0ff00010)
409      (#x01500010 . #x0ff00090))
410     ())
411   (define-arm-instruction cmn (:rd :shifter)
412     #x01700000
413     ((#x03700000 . #x0ff00000)
414      (#x01700000 . #x0ff00010)
415      (#x01700010 . #x0ff00090))
416     ())
417   (define-arm-instruction cmns (:rd :shifter)
418     #x01700000
419     ((#x03700000 . #x0ff00000)
420      (#x01700000 . #x0ff00010)
421      (#x01700010 . #x0ff00090))
422     ())
423
424   ;; (ba subprim-name) -> (mov pc ($ subprim-address))
425   (define-arm-instruction ba (:subprim)
426     #x03a0f000
427     #x0ffff000
428     ())
429   
430   (define-arm-instruction mov (:rd :shifter)
431     #x01a00000
432     ((#x03a00000 . #x0ff00000)
433      (#x01a00000 . #x0ff00010)
434      (#x01a00010 . #x0ff00090))
435     ())
436   (define-arm-instruction movs (:rd :shifter)
437     #x01b00000
438     ((#x03b00000 . #x0ff00000)
439      (#x01b00000 . #x0ff00010)
440      (#x01b00010 . #x0ff00090))
441     ())
442   (define-arm-instruction mvn (:rd :shifter)
443     #x01e00000
444     ((#x03e00000 . #x0ff00000)
445      (#x01e00000 . #x0ff00010)
446      (#x01e00010 . #x0ff00090))
447     ())
448   (define-arm-instruction mvns (:rd :shifter)
449     #x01f00000
450     ((#x03f00000 . #x0ff00000)
451      (#x01f00000 . #x0ff00010)
452      (#x01f00010 . #x0ff00090))
453     ())
454
455   (define-arm-instruction ldr (:rd :mem12)
456     #x04100000
457     #x0c500000
458     ())
459   (define-arm-instruction ldrb (:rd :mem12)
460     #x04500000
461     #x0c500000
462     ())
463   (define-arm-instruction str (:rd :mem12)
464     #x04000000
465     #x0c500000
466     ())
467   (define-arm-instruction strb (:rd :mem12)
468     #x04400000
469     #x0c500000
470     ())
471   (define-arm-instruction ldrh (:rd :mem8)
472     #x001000b0
473     #x0e3000f0
474     ())
475   (define-arm-instruction strh (:rd :mem8)
476     #x000000b0
477     #x0e3000f0
478     ())
479   (define-arm-instruction ldrsh (:rd :mem8)
480     #x001000f0
481     #x0e3000f0
482     ())
483   (define-arm-instruction ldrsb (:rd :mem8)
484     #x001000d0
485     #x0e3000f0
486     ())
487
488   (define-arm-instruction stm (:rnw :reglist)
489     #x08800000
490     #x0ff00000
491     ())
492   (define-arm-instruction stmia (:rnw :reglist)
493     #x08800000
494     #x0ff00000
495     ())
496   (define-arm-instruction stmea (:rnw :reglist)
497     #x08800000
498     #x0ff00000
499     ())
500   (define-arm-instruction ldmia (:rnw :reglist)
501     #x08900000
502     #x0ff00000
503     ())
504   (define-arm-instruction ldm (:rnw :reglist)
505     #x08900000
506     #x0ff00000
507     ())
508   (define-arm-instruction ldmfd (:rnw :reglist)
509     #x08900000
510     #x0ff00000
511     ())
512   (define-arm-instruction stmdb (:rnw :reglist)
513     #x09000000
514     #x0ff00000
515     ())
516   (define-arm-instruction stmfb (:rnw :reglist)
517     #x09000000
518     #x0ff00000
519     ())
520   (define-arm-instruction stmfd (:rnw :reglist)
521     #x09000000
522     #x0ff00000
523     ())
524   (define-arm-instruction ldmdb (:rnw :reglist)
525     #x09100000
526     #x0ff00000
527     ())
528   (define-arm-instruction ldmea (:rnw :reglist)
529     #x09100000
530     #x0ff00000
531     ())
532
533   (define-arm-instruction b (:b)
534     #x0a000000
535     #x0e000000
536     ())
537   (define-arm-instruction bl (:b)
538     #x0b000000
539     #x0e000000
540     ())
541   (define-arm-instruction bx (:rm)
542     #x012fff10
543     #x0ffffff0
544     ())
545   (define-arm-instruction blx (:rm)
546     #x012fff30
547     #x0ffffff0
548     ())
549   ))
550
551(dotimes (i (length *arm-instruction-table*))
552  (let* ((template (svref *arm-instruction-table* i))
553         (name (arm-instruction-template-name template)))
554    (setf (arm-instruction-template-ordinal template) i
555          (gethash name *arm-instruction-ordinals*) i)))
556
557   
558
559
560
561(defun lookup-arm-instruction (name)
562  ;; return (values instruction template & condition value), or (NIL NIL)
563  (let* ((cond-value #xe)              ;always
564         (string (string name))
565         (len (length string))
566         (ordinal (gethash string *arm-instruction-ordinals*))
567         (template (if ordinal (aref *arm-instruction-table* ordinal))))
568    (if template
569      (values template (unless (logbitp (encode-arm-instruction-flag :non-conditional) (arm-instruction-template-flags template)) cond-value) nil)
570      (if (> len 2)
571        (let* ((cond-name (make-string 2)))
572          (declare (dynamic-extent cond-name))
573          (setf (schar cond-name 0)
574                (schar string (- len 2))
575                (schar cond-name 1)
576                (schar string (- len 1)))
577          (if (setq cond-value (lookup-arm-condition-name cond-name))
578            (let* ((prefix-len (- len 2))
579                   (prefix (make-string prefix-len)))
580              (declare (dynamic-extent prefix)
581                       (fixnum prefix-len))
582              (dotimes (i prefix-len)
583                (setf (schar prefix i) (schar string i)))
584              (if (setq template
585                        (progn
586                          (setq ordinal (gethash prefix *arm-instruction-ordinals*))
587                          (when ordinal
588                            (svref *arm-instruction-table* ordinal))))
589                (if (logbitp (encode-arm-instruction-flag :non-conditional) (arm-instruction-template-flags template))
590                  (values nil nil nil)
591                  (values template cond-value t))
592                (values nil nil nil)))
593            (values nil nil nil)))
594        (values nil nil nil)))))
595
596(defun keywordize (name)
597  (if (typep name 'keyword)
598    name
599    (intern (string-upcase (string name)) "KEYWORD")))
600
601(defun arm-rotate-left (u32 nbits)
602  (assert (and (evenp nbits)
603               (>= nbits 0)
604               (< nbits 32)))
605  (let* ((r (- 32 nbits))
606         (mask (1- (ash 1 nbits))))
607    (logand #xffffffff
608            (logior (ash u32 nbits)
609                    (logand mask
610                            (ash  u32 (- r)))))))
611
612;;; Return a 12-bit value encoding u32 as an 8-bit constant rotated
613;;; by an even number of bits if u32 can be encoded that way, nil
614;;; otherwise.
615(defun encode-arm-immediate (u32)
616  (do* ((u32 (logand #xffffffff u32))
617        (rot 0 (+ rot 2)))
618       ((= rot 32) (values nil nil))
619    (let* ((a (arm-rotate-left u32 rot)))
620      (when (<= a #xff)
621        (return (logior (ash rot 7) a))))))
622
623
624(eval-when (:execute :load-toplevel)
625  (defstruct (instruction-element (:include ccl::dll-node))
626    address
627    (size 0))
628
629;;; A LAP-INSTRUCTION's field-values list contains (byte-spec . value)
630;;; pairs, where the byte-spec is encoded as a fixnum.  If the BYTE-SIZE
631;;; of the byte-spec is non-zero, the value is to be inserted in the
632;;; instruction by DPB; if the BYTE-SIZE is zero, the BYTE-POSITION of
633
634;;; the byte-spec is used to select a function which affects arbitrary
635;;; bitfields in the instruction.  (E.g., a negative constant in an ADD
636;;; instruction might turn the instruction into a SUB.)
637;;; The relationship between logical operands and field-values isn't
638;;; necessarily 1:1.
639;;; For vinsn expansion, the field values with constant values can
640;;; be applied at vinsn-definition time.
641 
642  (defstruct (lap-instruction (:include instruction-element (size 4))
643                              (:constructor %make-lap-instruction (source)))
644    source                              ; for LAP, maybe vinsn-template
645    (opcode 0)
646    vinsn-info                          ;tbd
647    )
648
649   
650  (defstruct (lap-label (:include instruction-element)
651                            (:constructor %%make-lap-label (name)))
652    name
653    refs))
654
655(ccl::def-standard-initial-binding *lap-label-freelist* (ccl::make-dll-node-freelist))
656(ccl::def-standard-initial-binding *lap-instruction-freelist* (ccl::make-dll-node-freelist))
657
658
659(eval-when (:compile-toplevel :execute)
660  (declaim (inline set-field-value)))
661
662(defun set-field-value (instruction bytespec value)
663  (setf (lap-instruction-opcode instruction)
664        (dpb value bytespec (lap-instruction-opcode instruction))))
665
666
667(defun need-arm-gpr (form)
668  (or (get-arm-gpr form)
669      (error "Expected an ARM general-purpose register, got ~s" form)))
670
671(defun encode-arm-shift-type (op)
672  (case op
673    (:lsl 0)
674    (:lsr 1)
675    (:asr 2)
676    (:ror 3)))
677
678
679(defconstant opcode-and 0)
680(defconstant opcode-eor 1)
681(defconstant opcode-sub 2)
682(defconstant opcode-rsb 3)
683(defconstant opcode-add 4)
684(defconstant opcode-adc 5)
685(defconstant opcode-sbc 6)
686(defconstant opcode-rsc 7)
687(defconstant opcode-tst 8)
688(defconstant opcode-teq 9)
689(defconstant opcode-cmp 10)
690(defconstant opcode-cmn 11)
691(defconstant opcode-orr 12)
692(defconstant opcode-mov 13)
693(defconstant opcode-bic 14)
694(defconstant opcode-mvn 15)
695
696(defvar *equivalent-complemented-opcodes*
697  (vector opcode-bic                    ;and->bic
698          nil                           ;eor->
699          nil                           ;sub->
700          nil                           ;rsb->
701          nil                           ;add->
702          opcode-sbc                    ;adc->sbc
703          opcode-adc                    ;sbc->adc
704          nil                           ;rsc->
705          nil                           ;tst->
706          nil                           ;cmp->
707          nil                           ;cmn->
708          nil                           ;orr->
709          opcode-mvn                    ;mov->mvn
710          opcode-and                    ;bic->and
711          opcode-mov                    ;mvn->mov
712          ))
713
714(defvar *equivalent-negated-opcodes*
715  (vector nil                           ;and->
716          nil                           ;eor->
717          opcode-add                    ;sub->add
718          nil                           ;rsb->
719          opcode-sub                    ;add->sub
720          nil                           ;adc->
721          nil                           ;sbc->
722          nil                           ;rsc->
723          nil                           ;tst->
724          opcode-cmn                    ;cmp->cmn
725          opcode-cmp                    ;cmn->cmp
726          nil                           ;orr->
727          nil                           ;mov->
728          nil                           ;bic->
729          nil                           ;mvn->
730          ))
731
732
733   
734(defun parse-rd-operand (form instruction)
735  (set-field-value instruction (byte 4 12) (need-arm-gpr form)))
736
737(defun parse-rn-operand (form instruction)
738  (set-field-value instruction (byte 4 16) (need-arm-gpr form)))
739
740(defun parse-shifter-operand (form instruction)
741  (if (atom form)
742    ;; rm is shorthand for (:lsl rm (:$ 0)); the :lsl is encoded as 0.
743    (set-field-value instruction (byte 12 0) (need-arm-gpr form))
744    (if (ccl::quoted-form-p form)
745      (insert-shifter-constant (need-constant form) instruction)
746      (let* ((op (keywordize (car form))))
747        (ecase op
748          (:$ (destructuring-bind (value) (cdr form)
749                (insert-shifter-constant (eval value) instruction)))
750          (:rrx (destructuring-bind (reg) (cdr form)
751                  (set-field-value instruction (byte 12 0)
752                                   (logior (need-arm-gpr reg)
753                                           (ash (encode-arm-shift-type :ror) 5)))))
754          ((:lsl :lsr :asr :ror)
755           (destructuring-bind (reg count) (cdr form)
756             (if (atom count)
757               (set-field-value instruction (byte 12 0)
758                                (logior (need-arm-gpr reg)
759                                        (ash 1 4)
760                                        (ash (encode-arm-shift-type op) 5)
761                                        (ash (need-arm-gpr count) 8)))
762               (ecase (keywordize (car count))
763                 (:$ (destructuring-bind (countval) (cdr count)
764                       (set-field-value instruction (byte 12 0)
765                                        (logior (need-arm-gpr reg)
766                                                (ash (encode-arm-shift-type op) 5)
767                                                (ash (logand 31 (eval countval)) 7))))))))))))))
768     
769(defun insert-shifter-constant (value instruction)
770  (let* ((opcode (lap-instruction-opcode instruction))
771         (constant (encode-arm-immediate value)))
772    (setf (lap-instruction-opcode instruction)
773          (if constant
774            (logior constant (logior (ash 1 25) opcode))
775            ;; If value couldn't be encoded but its complement can be
776            ;; and there's an instruction that can operate on complemented
777            ;; values, change the instruction and encode the complemented
778            ;; value.  If that doesn't work, try negating the value and
779            ;; seeing if there's an equivalent instruction that could use
780            ;; that.  If none of this works, complain that the value can't
781            ;; be encoded.
782            (let* ((op (ldb (byte 4 21) opcode))
783                   (newop nil))
784              (if (or (and (setq constant (encode-arm-immediate (lognot value)))
785                           (setq newop (svref *equivalent-complemented-opcodes* op)))
786                      (and (setq constant (encode-arm-immediate (- value)))
787                           (setq newop (svref *equivalent-negated-opcodes* op))))
788                (logior constant
789                        (logior (ash 1 25) (dpb newop (byte 4 21) opcode)))
790                (error "Can't encode ARM constant ~s." value)))))))
791
792(defun set-opcode-value-from-addressing-mode (opcode mode constant-index)
793  ;; Look at mode and set P/W/U bits.  If CONSTANT-INDEX is
794  ;; true, the U bit depends on the sign of the constant.
795  (ecase mode           
796    ((:@ :+@ :+@! :@!)
797     ;; Preindexed, no writeback unless :+@! , add register operands.
798     (unless constant-index
799       (setq opcode (logior opcode (ash 1 23))))
800     (when (eq mode :+@!)
801       (setq opcode (logior opcode (ash 1 21))))
802     (setq opcode (logior opcode (ash 1 24))))
803    ((:-@ :-@!)
804     ;; Preindexed. Leave the U bit clear, maybe set W if writeback.
805     (when (eq mode :-@!)
806       (setq opcode (logior opcode (ash 1 21))))
807     (setq opcode (logior opcode (ash 1 24))))
808    ((:@+ :@-)
809     ;; Postindex; writeback is implicit (and setting P and W would
810     ;; change the instruction.)
811     (unless (or (eq mode :@-) constant-index)
812       (setq opcode (logior opcode (ash 1 23))))))
813  opcode)
814
815
816(defun set-addressing-mode (instruction mode constant-index)
817  (setf (lap-instruction-opcode instruction)
818        (set-opcode-value-from-addressing-mode
819         (lap-instruction-opcode instruction) mode constant-index)))
820
821;;; "general" address operand, as used in LDR/LDRB/STR/STRB
822(defun parse-m12-operand (form instruction)
823  (if (atom form)
824    (error "Invalid memory operand ~s" form)   
825    (let* ((mode (keywordize (car form))))
826      (if (eq mode :=)
827        (destructuring-bind (label) (cdr form)
828          (when (arm::arm-subprimitive-address label)
829            (error "Invalid label in ~s." form))
830          (set-field-value instruction (byte 4 16) arm::pc)
831          (set-field-value instruction (byte 1 24) 1) ;P bit
832          ;; Insert function will have to set U bit appropriately.
833          (lap-note-label-reference label instruction :mem12))
834        (destructuring-bind (rn &optional (index '(:$ 0) index-p)) (cdr form)
835          (unless (or index-p (eq mode :@))
836            (error "missing index in memory operand ~s." form))
837          (set-field-value instruction (byte 4 16) (need-arm-gpr rn))
838          (let* ((quoted (ccl::quoted-form-p index))
839                 (index-op (if quoted :quote (and (consp index) (keywordize (car index)))))
840                 (constant-index (or quoted (eq index-op :$))))
841            (cond (constant-index
842                   (destructuring-bind (val) (cdr index)
843                     (let* ((constval (if quoted
844                                        (need-constant index)
845                                        (eval val))))
846                       (if (< constval 0)
847                         (setq constval (- constval))
848                         ;; das u bit
849                         (set-field-value instruction (byte 1 23) 1))
850                       (unless (typep constval '(unsigned-byte 12))
851                         (warn "constant offset too large : ~s" constval))
852                       (set-field-value instruction (byte 12 0) constval))))
853                  (t
854                   (set-field-value instruction (byte 1 25) 1)
855                   (if (atom index)
856                     (set-field-value instruction (byte 12 0) (need-arm-gpr index))
857                     ;; Shifts here are always by a constant (not another reg)
858                     (if (eq index-op :rrx)
859                       (destructuring-bind (rm) (cdr index)
860                         (set-field-value instruction (byte 12 0)
861                                          (logior (need-arm-gpr rm)
862                                                  (ash (encode-arm-shift-type :ror) 5))))
863                     
864                       (destructuring-bind (rm shift-expr) (cdr index)
865                         (unless (and (consp shift-expr)
866                                      (eq (keywordize (car shift-expr)) :$))
867                           (error "Shift count must be immediate : ~s" shift-expr))
868                         (destructuring-bind (count-expr) (cdr shift-expr)
869                           (set-field-value instruction (byte 12 0)
870                                            (logior (need-arm-gpr rm)
871                                                    (ash (encode-arm-shift-type
872                                                          index-op) 5)
873                                                    (ash (logand 31 (eval count-expr))
874                                                         7)))))))))
875            (set-addressing-mode instruction mode constant-index)))))))
876
877(defun parse-reglist-operand (form instruction)
878  (let* ((mask 0))
879    (dolist (r form)
880      (let* ((regno (need-arm-gpr r)))
881        (when (logbitp regno mask)
882          (warn "Duplicate register ~s in ~s." r form))
883        (setq mask (logior mask (ash 1 regno)))))
884    (if (zerop mask)
885      (error "Empty register list ~s." form)
886      (set-field-value instruction (byte 16 0) mask))))
887
888(defun parse-rnw-operand (form instruction)
889  (if (atom form)
890    (set-field-value instruction (byte 4 16) (need-arm-gpr form))
891    (if (eq (keywordize (car form)) :!)
892      (destructuring-bind (rn) (cdr form)
893        (set-field-value instruction (byte 1 21) 1)
894        (set-field-value instruction (byte 4 16) (need-arm-gpr rn)))
895      (error "Unrecognized writeback indicator in ~s." form))))
896
897(defun parse-uuoA-operand (form instruction)
898  (set-field-value instruction (byte 4 8) (need-arm-gpr form)))
899
900(defun parse-uuo-unary-operand (form instruction)
901  (set-field-value instruction (byte 8 12) (need-constant form)))
902
903(defun parse-uuoB-operand (form instruction)
904  (set-field-value instruction (byte 4 12) (need-arm-gpr form)))
905
906(defun parse-rm-operand (form instruction)
907  (set-field-value instruction (byte 4 0) (need-arm-gpr form)))
908
909(defun parse-b-operand (form instruction)
910  (let* ((address (arm-subprimitive-address form)))
911    (if address
912      (let* ((lab (or (find-lap-label form)
913                      (make-lap-label form))))
914        (pushnew lab *called-subprim-jmp-labels*)
915        (push (cons instruction :b) (lap-label-refs lab)))
916      (lap-note-label-reference form instruction :b))))
917
918(defun parse-subprim-operand (form instruction) 
919  (let* ((address (arm-subprimitive-address form)))
920    (unless address
921      (error "Unknown ARM subprimitive : ~s" form))
922    (set-field-value instruction (byte 12 0) (encode-arm-immediate address))))
923   
924(defun parse-m8-operand (form instruction)
925  (if (atom form)
926    (error "Invalid memory operand ~s." form)
927    (let* ((mode (keywordize (car form)))
928           (constant-index nil))
929      (destructuring-bind (rn index) (cdr form)
930        (set-field-value instruction (byte 4 16) (need-arm-gpr rn))
931        (cond ((atom index)
932               (set-field-value instruction (byte 4 0) (need-arm-gpr index))
933               (set-field-value instruction (byte 25 1) 1))
934              (t (unless (eq (keywordize (car index)) :$)
935                   (error "Invalid index: ~s." index))
936                 (destructuring-bind (val) (cdr index)
937                   (let* ((value (eval val)))
938                     (setq constant-index t)
939                     (if (< value 0)
940                       (setq value (- value))
941                       (set-field-value instruction (byte 23 1) 1))
942                     (set-field-value instruction (byte 4 0) (ldb (byte 4 0) value))
943                     (set-field-value instruction (byte 4 8) (ldb (byte 4 4) value)))))))
944    (set-addressing-mode instruction mode constant-index))))
945       
946                             
947         
948
949(defparameter *arm-operand-parsers*
950    #(parse-rd-operand
951      parse-rn-operand
952      parse-shifter-operand
953      parse-m12-operand
954      parse-reglist-operand
955      parse-rnw-operand
956      parse-uuoa-operand
957      parse-uuo-unary-operand
958      parse-uuob-operand
959      parse-rm-operand
960      parse-b-operand
961      parse-subprim-operand
962      parse-m8-operand
963      ))
964
965
966
967(defun make-lap-instruction (form)
968  (let* ((insn (ccl::alloc-dll-node *lap-instruction-freelist*)))
969    (if (typep insn 'lap-instruction)
970      (progn
971        (setf (lap-instruction-source insn) form
972              (lap-instruction-address insn) nil
973              (lap-instruction-vinsn-info insn) nil
974              (lap-instruction-opcode insn) nil)
975        insn)
976      (%make-lap-instruction form))))
977
978;;; FORM is a list and its car isn't a pseudo-op or lapmacro; try to
979;;; generate an instruction.
980(defun assemble-instruction (seg form)
981  (let* ((insn (make-lap-instruction form)))
982    (destructuring-bind (name . opvals) form
983      (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name)
984        (unless template
985          (error "Unknown ARM instruction - ~s" form))
986        (let* ((cond-indicator (and (consp (car opvals))
987                                    (keywordize (caar opvals)))))
988          (when (or (eq cond-indicator :?)
989                    (eq cond-indicator :~))
990            (let* ((condform (pop opvals)))
991              (destructuring-bind (q cond-name) condform
992                (declare (ignore q))
993                (let* ((c (need-arm-condition-name cond-name)))
994                  (when (eq cond-indicator :~)
995                    (if (< c 14)
996                      (setq c (logxor c 1))
997                      (error "Invalid explicit condition ~s." condform)))
998                  (if (and explicit-cond (not (eql c cond)))
999                    (error "Can't use explicit condition and :? : ~s" condform)
1000                    (setq cond c)))))))
1001        (let* ((optypes (arm-instruction-template-operand-types template))
1002               (n (length optypes)))
1003          (unless (= n (length opvals))
1004            (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form))
1005          (setf (lap-instruction-opcode insn)
1006                (arm-instruction-template-val template))
1007          (dotimes (i n)
1008            (let* ((optype (pop optypes))
1009                   (val (pop opvals)))
1010              (funcall (svref *arm-operand-parsers* optype) val insn)))
1011          (when cond
1012            (setf (lap-instruction-opcode insn)
1013                  (dpb cond (byte 4 28) (lap-instruction-opcode insn))))
1014          (ccl::append-dll-node insn seg))))))
1015
1016;;; A label can only be emitted once.  Once it's been emitted, its pred/succ
1017;;; slots will be non-nil.
1018
1019(defun lap-label-emitted-p (lab)
1020  (not (null (lap-label-pred lab))))
1021
1022(defun %make-lap-label (name)
1023  (let* ((lab (ccl::alloc-dll-node *lap-label-freelist*)))
1024    (if lab
1025      (progn
1026        (setf (lap-label-address lab) nil
1027              (lap-label-refs lab) nil
1028              (lap-label-name lab) name)
1029        lab)
1030      (%%make-lap-label name))))
1031
1032(defun make-lap-label (name)
1033  (let* ((lab (%make-lap-label name)))
1034    (if (typep *lap-labels* 'hash-table)
1035      (setf (gethash name *lap-labels*) lab)
1036      (progn
1037        (push lab *lap-labels*)
1038        (if (> (length *lap-labels*) 255)
1039          (let* ((hash (make-hash-table :size 512 :test #'eq)))
1040            (dolist (l *lap-labels* (setq *lap-labels* hash))
1041              (setf (gethash (lap-label-name l) hash) l))))))
1042    lab))
1043
1044(defun find-lap-label (name)
1045  (if (typep *lap-labels* 'hash-table)
1046    (gethash name *lap-labels*)
1047    (car (member name *lap-labels* :test #'eq :key #'lap-label-name))))
1048
1049(defun lap-note-label-reference (labx insn type)
1050  (let* ((lab (or (find-lap-label labx)
1051                  (make-lap-label labx))))
1052    (push (cons insn type) (lap-label-refs lab))
1053    lab))
1054
1055(defun emit-lap-label (seg name)
1056  (let* ((lab (find-lap-label name)))
1057    (if  lab 
1058      (when (lap-label-emitted-p lab)
1059        (error "Label ~s: multiply defined." name))
1060      (setq lab (make-lap-label name)))
1061    (ccl::append-dll-node lab seg)))
1062
1063(defmacro do-lap-labels ((lab &optional result) &body body)
1064  (let* ((thunk-name (gensym))
1065         (k (gensym))
1066         (xlab (gensym)))
1067    `(flet ((,thunk-name (,lab) ,@body))
1068      (if (listp *lap-labels*)
1069        (dolist (,xlab *lap-labels*)
1070          (,thunk-name ,xlab))
1071        (maphash #'(lambda (,k ,xlab)
1072                     (declare (ignore ,k))
1073                     (,thunk-name ,xlab))
1074                 *lap-labels*))
1075      ,result)))
1076
1077(defun set-element-addresses (start seg)
1078  (ccl::do-dll-nodes (element seg start)
1079    (setf (instruction-element-address element) start)
1080    (incf start (instruction-element-size element))))
1081
1082(defun count-element-sizes (seg)
1083  (let* ((start 0))
1084    (ccl::do-dll-nodes (element seg start)
1085    (incf start (instruction-element-size element)))))
1086
1087(defun arm-finalize (primary constant-pool)
1088  (dolist (lab *called-subprim-jmp-labels*)
1089    (unless (lap-label-emitted-p lab)
1090      (ccl::append-dll-node lab primary)
1091      (assemble-instruction primary `(ba ,(lap-label-name lab)))))
1092  (let* ((constants-size (count-element-sizes constant-pool)))
1093    (unless (eql constants-size 0)
1094      (let* ((c0 (make-lap-instruction nil)))
1095        (setf (lap-instruction-opcode c0) (ash constants-size -2))
1096        (ccl::insert-dll-node-before c0 (ccl::dll-header-first constant-pool)))))
1097  (let* ((w0 (make-lap-instruction nil))
1098         (w1 (make-lap-instruction nil)))
1099    (setf (lap-instruction-opcode w0) 0)
1100    (ccl::append-dll-node w0 primary)
1101    (ccl::append-dll-node w1 primary )
1102    (let* ((n (set-element-addresses 0 primary)))
1103      (setf (lap-instruction-opcode w1) n)
1104      (set-element-addresses n constant-pool)))
1105  ;; Now fix up label references.  Recall that the PC value at some
1106  ;; point in program execution is 8 bytes beyond that point.
1107  (do-lap-labels (lab)
1108    (if (lap-label-emitted-p lab)
1109      (let* ((labaddr (lap-label-address lab)))
1110        (dolist (ref (lap-label-refs lab))
1111          (destructuring-bind (insn . reftype) ref
1112            (let* ((diff-in-bytes (- labaddr (+ 8 (lap-instruction-address insn)))))
1113              (case reftype
1114                (:b (setf (lap-instruction-opcode insn)
1115                          (dpb (ash diff-in-bytes -2)
1116                               (byte 24 0)
1117                               (lap-instruction-opcode insn))))
1118                (:mem12
1119                 (if (>= diff-in-bytes 0)
1120                   (set-field-value insn (byte 1 23) 1)
1121                   (setq diff-in-bytes (- diff-in-bytes)))
1122                 (set-field-value insn (byte 12 0) diff-in-bytes))
1123                (t
1124                 (error "Label type ~s invalid or not yet supported."
1125                        reftype)))))))
1126      (if (lap-label-refs lab)
1127        (error "LAP label ~s was referenced but not defined." (lap-label-name lab)))))
1128  (ccl::merge-dll-nodes primary constant-pool)
1129  (let* ((last (ccl::dll-header-last primary)))
1130    (ash (+ (instruction-element-address last)
1131            (instruction-element-size last)) -2)))
1132
1133;;; We want to be able to write vinsn templates using a (mostly) LAP-like
1134;;; syntax, but ideally don't want to have to repeatedly expand those
1135;;; vinsn-definition-time-invariant elements of that syntax.
1136;;;
1137;;; For example, if DEST is a vinsn parameter and the vinsn body
1138;;; contains:
1139;;;
1140;;;   (ldr DEST (:@ rcontext (:$ arm::tcr.db-link)))
1141;;;
1142;;; then we know at definition time:
1143;;;  1) the opcode of the LDR instruction (obviously)
1144;;;  2) the fact that the LDR's :mem12 operand uses indexed
1145;;;     addressing with an immediate operand and no writeback
1146;;;  3) in this example, we also know the value of the RB field
1147;;;     and the value of the immediate operand, which happens
1148;;;     to be positive (setting the U bit).
1149;;;
1150;;;  We can apply this knowledge at definition time, and set
1151;;;  the appropriate bits (U, RN, IMM12) in the opcode.
1152;;;
1153;;;  We don't, of course, know the value of DEST at vinsn-definition
1154;;;  time, but we do know that it's the Nth vinsn parameter, so we
1155;;;  can turn this example into something like:
1156;;;
1157;;;  `(,(augmented-opcode-for-LDR) #(rd-field) #(index-of-DEST)
1158;;;
1159;;; This is defined here (rather than in the compiler backend) since
1160;;; it needs to know a lot about ARM instruction encoding.
1161
1162(defstruct (arm-vinsn-instruction (:constructor %make-arm-vinsn-instruction)
1163                                  (:conc-name avi-))
1164  head
1165  tail)
1166
1167(defun make-arm-vinsn-instruction (opcode)
1168  (let* ((head (list opcode)))
1169    (%make-arm-vinsn-instruction :head head :tail head)))
1170
1171(defun add-avi-operand (instruction field-type value)
1172  (let* ((tail (avi-tail instruction)))
1173    (setf (avi-tail instruction)
1174          (cdr (rplacd tail (cons (cons field-type value) nil))))))
1175
1176(defun avi-opcode (avi)
1177  (car (avi-head avi)))
1178
1179(defun (setf avi-opcode) (new avi)
1180  (setf (car (avi-head avi)) new))
1181
1182(defun set-avi-opcode-field (avi bytespec value)
1183  (setf (avi-opcode avi)
1184        (dpb value bytespec (avi-opcode avi)))
1185  value)
1186
1187
1188(defparameter *vinsn-field-types*
1189  #(:cond
1190    :negated-cond
1191    :rn
1192    :rd
1193    :rm
1194    :rs
1195    :alu-constant
1196    :shift-count                        ;shift type is always explicit
1197    :mem12-offset
1198    :mem8-offset
1199    :reglist-bit
1200    :uuoA
1201    :uuo-unary
1202    :uuoB
1203    :label
1204    :subprim
1205    :application
1206    :local-label
1207    ))
1208
1209(defmacro encode-vinsn-field-type (name)
1210  (or (position name *vinsn-field-types*)
1211      (error "Unknown vinsn-field-type name ~s." name)))
1212
1213(defparameter *arm-vinsn-operand-parsers*
1214    #(vinsn-parse-rd-operand
1215      vinsn-parse-rn-operand
1216      vinsn-parse-shifter-operand
1217      vinsn-parse-m12-operand
1218      vinsn-parse-reglist-operand
1219      vinsn-parse-rnw-operand
1220      vinsn-parse-uuoa-operand
1221      vinsn-parse-uuo-unary-operand
1222      vinsn-parse-uuob-operand
1223      vinsn-parse-rm-operand
1224      vinsn-parse-b-operand
1225      vinsn-parse-subprim-operand
1226      vinsn-parse-m8-operand
1227      ))
1228
1229(defun vinsn-arg-or-gpr (avi form vinsn-params encoded-type bytespec)
1230  (let* ((p (position form vinsn-params)))
1231    (cond (p
1232           (add-avi-operand avi encoded-type p)
1233           nil)
1234          (t           
1235           (set-avi-opcode-field avi bytespec (need-arm-gpr form))))))
1236
1237(defun vinsn-arg-or-constant (avi form vinsn-params encoded-type bytespec)
1238  (let* ((p (position form vinsn-params)))
1239    (cond (p
1240           (add-avi-operand avi encoded-type p)
1241           nil)
1242          ((and (consp form) (eq (car form) :apply))
1243           (add-avi-operand avi encoded-type (simplify-application form vinsn-params))
1244           nil)
1245          (t
1246           (let* ((val (eval form)))
1247             (when bytespec
1248               (set-avi-opcode-field avi bytespec val))
1249             val)))))
1250
1251
1252
1253(defun vinsn-parse-rd-operand (avi value vinsn-params)
1254  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rd) (byte 4 12)))
1255
1256(defun vinsn-parse-rn-operand (avi value vinsn-params)
1257  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rn) (byte 4 16)))
1258
1259(defun vinsn-parse-shifter-operand (avi value vinsn-params)
1260  (if (atom value)
1261    (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1262    (ecase (car value)
1263      (:$
1264       (destructuring-bind (v) (cdr value)
1265         (let* ((val (vinsn-arg-or-constant avi v vinsn-params (encode-vinsn-field-type :alu-constant) nil)))
1266           (when val
1267             (let* ((constant (encode-arm-immediate val)))
1268               (if constant
1269                 (set-avi-opcode-field avi (byte 1 25) 1)
1270                 (let* ((op (ldb (byte 4 21) (avi-opcode avi)))
1271                        (newop nil))
1272                   (if (or (and (setq constant (encode-arm-immediate (lognot val)))
1273                                (setq newop (svref *equivalent-complemented-opcodes* op)))
1274                           (and (setq constant (encode-arm-immediate (- val)))
1275                                (setq newop (svref *equivalent-negated-opcodes* op))))
1276                     (progn
1277                       (set-avi-opcode-field avi (byte 1 25) 1)
1278                       (set-avi-opcode-field avi (byte 4 21) newop)
1279                       (set-avi-opcode-field avi (byte 12 0) constant))
1280                     
1281                     (error "Can't encode ARM constant ~s." value)))))))))
1282      (:rrx
1283       (destructuring-bind (rm) (cdr value)
1284         (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1285         (set-avi-opcode-field avi (byte 2 5) 3)))
1286      ((:lsl :lsr :asr :ror)
1287       (destructuring-bind (rm count) (cdr value)
1288         (set-avi-opcode-field avi (byte 2 5) (encode-arm-shift-type (car value)))
1289         (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1290         (cond
1291           ((atom count)
1292            (set-avi-opcode-field avi (byte 1 4) 1)
1293            (vinsn-arg-or-gpr avi count vinsn-params (encode-vinsn-field-type :rs) (byte 4 8)))
1294           (t
1295            (unless (eq (car count) :$)
1296              (error "Invalid shift count: ~s" count)
1297              (destructuring-bind (countval) (cdr count)
1298                (vinsn-arg-or-constant avi countval vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7)))))))))))
1299
1300(defun vinsn-parse-m12-operand (avi value vinsn-params)
1301  (destructuring-bind (op rn index) value     ; no (:@ reg) sugar
1302    (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16))
1303    (let* ((constant-index (and (consp index) (eq (car index) :$))))
1304      (unless constant-index
1305        (set-avi-opcode-field avi (byte 1 25) 1))
1306      (cond
1307        ((atom index)
1308         (vinsn-arg-or-gpr avi index vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)))
1309        (constant-index
1310         (destructuring-bind (constform) (cdr index)
1311           (let* ((constval
1312                   (vinsn-arg-or-constant avi constform vinsn-params (encode-vinsn-field-type :mem12-offset) nil)))
1313             (when constval
1314               (if (< constval 0)
1315                 (setq constval (- constval))
1316                 (set-avi-opcode-field avi (byte 1 23) 1))
1317               (unless (typep constval '(unsigned-byte 12))
1318                 (warn "constant offset too large : ~s" constval))
1319               (set-avi-opcode-field avi (byte 12 0) constval)))))
1320        ((eq (car index) :rrx)
1321         (destructuring-bind (rm) (cdr index)
1322           (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1323           (set-avi-opcode-field avi (byte 2 5) 3)))
1324        (t
1325         (destructuring-bind (shift-op rm shift-count) index
1326           (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1327           (set-avi-opcode-field avi (byte 2 5) (encode-arm-shift-type shift-op))
1328
1329           (unless (and (consp shift-count)
1330                        (eq (car shift-count) :$))
1331             (error "Invalid shift-count: ~s" shift-count))
1332           (destructuring-bind (shift-count-form) (cdr shift-count)
1333             (vinsn-arg-or-constant avi shift-count-form vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7))))))
1334      (setf (avi-opcode avi)
1335            (set-opcode-value-from-addressing-mode (avi-opcode avi) op constant-index)))))
1336
1337(defun vinsn-parse-reglist-operand (avi value vinsn-params)
1338  (dolist (r value)
1339    (let* ((p (position r vinsn-params)))
1340      (if p
1341        (progn
1342          (vector-push-extend (encode-vinsn-field-type :reglist-bit)
1343                              field-types)
1344          (vector-push-extend p field-values))
1345        (let* ((bit (need-arm-gpr r)))
1346          (setq opcode (logior opcode (ash 1 bit))))))))
1347
1348(defun vinsn-parse-rnw-operand (avi value vinsn-params)
1349  (let* ((rn (if (atom value)
1350               value
1351               (destructuring-bind (marker reg) value
1352                 (if (eq marker :!)
1353                   (set-avi-opcode-field avi (byte 1 21) 1))
1354                   (error "Unrecognized writeback indicator in ~s." value)
1355                 reg))))
1356    (vinsn-arg-or-gpr avi rn vinsn-params  (encode-vinsn-field-type :rn) (byte 4 16))))
1357
1358(defun vinsn-parse-uuoA-operand (avi value vinsn-params)
1359  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :uuoA) (byte 4 8)))
1360
1361(defun vinsn-parse-uuo-unary-operand (avi value vinsn-params)
1362  (when (or (atom value)
1363          (not (eq (car value) :$)))
1364    (error "Invalid constant syntax in ~s." value))
1365  (destructuring-bind (valform) (cdr value)
1366    (vinsn-arg-or-constant avi valform vinsn-params (encode-vinsn-field-type :uuo-unary) (byte 8 12))))
1367
1368(defun vinsn-parse-uuoB-operand (avi value vinsn-params)
1369  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :uuoB) (byte 4 12)))
1370
1371(defun vinsn-parse-rm-operand (avi value vinsn-params)
1372  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)))
1373
1374(defun vinsn-parse-b-operand (avi value vinsn-params)
1375  ;; Pretty much has to be a param or a local label what else would we b to ?
1376  (let* ((p (position value vinsn-params)))
1377    (cond (p
1378           (add-avi-operand avi (encode-vinsn-field-type :label) p))
1379          ((typep value 'keyword)
1380           (add-avi-operand avi (encode-vinsn-field-type :local-label) value))
1381          (t
1382           (error "Unknown branch target: ~s." value)))))
1383
1384;;; This can only appear in a BA (mov PC,(:$ addr)) instruction, which
1385;;; already has bit 25 set.
1386(defun vinsn-parse-subprim-operand (avi value vinsn-params)
1387  (let* ((p (position value vinsn-params)))
1388    (if p
1389      (add-avi-operand avi (encode-vinsn-field-type :subprim) p)
1390      (let* ((addr (or (arm-subprimitive-address value)
1391                   (and (typep value 'integer)
1392                        (>= value #x4000)
1393                        (< value #x10000)
1394                        (not (logtest #x7f value))))))
1395        (unless addr
1396          (error "Unknown ARM subprimitive address: ~s." addr))
1397        (set-avi-opcode-field avi (byte 12 0) (encode-arm-immediate addr))))))
1398
1399(defun vinsn-parse-m8-operand (avi value vinsn-params)
1400  (if (atom value)
1401    (error "Invalid memory operand ~s." value)
1402    (destructuring-bind (mode rn index) value
1403      (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16))
1404      (let* ((constant-index (and (consp index) (eq (car index) :$))))
1405        (unless constant-index
1406          (set-avi-opcode-field avi (byte 25 1) 1))
1407        (cond ((atom index)
1408               (vinsn-arg-or-gpr avi index vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)))
1409              (constant-index
1410               (destructuring-bind (constform) (cdr index)
1411                 (let* ((constval
1412                         (vinsn-arg-or-constant avi constform vinsn-params (encode-vinsn-field-type :mem8-offset) nil)))
1413                   (when constval
1414                     (if (< constval 0)
1415                       (setq constval (- constval))
1416                       (set-avi-opcode-field avi (byte 1 23) 1))
1417                     (unless (typep constval '(unsigned-byte 8))
1418                       (warn "constant offset too large : ~s" constval))
1419                     (set-avi-opcode-field avi (byte 4 0) (ldb (byte 4 0) constval))
1420                     (set-avi-opcode-field avi (byte 4 8) (ldb (byte 4 4) constval))))))
1421              ((eq (car index) :rrx)
1422               (destructuring-bind (rm) (cdr index)
1423                 (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1424                 (set-avi-opcode-field avi (byte 2 5) 3)))
1425              (t
1426               (destructuring-bind (shift-op rm shift-count) index
1427                 (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1428                 (set-avi-opcode-field avi (byte 2 5) (encode-arm-shift-type shift-op))
1429                 (unless (and (consp shift-count)
1430                              (eq (car shift-count) :$))
1431                   (error "Invalid shift-count: ~s" shift-count))
1432                 (destructuring-bind (shift-count-form) (cdr shift-count)
1433                   (vinsn-arg-or-constant avi shift-count-form vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7))))))
1434        (setf (avi-opcode avi)
1435              (set-opcode-value-from-addressing-mode (avi-opcode avi) mode constant-index))))))
1436
1437             
1438
1439
1440                                     
1441(defun vinsn-simplify-instruction (form vinsn-params)
1442  (destructuring-bind (name . opvals) form
1443    (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name)
1444      (unless template
1445        (error "Unknown ARM instruction - ~s" form))
1446      (let* ((cond-indicator (and (consp (car opvals))
1447                                  (keywordize (caar opvals))))
1448             (avi (make-arm-vinsn-instruction (arm-instruction-template-val template))))
1449        (when (or (eq cond-indicator :?)
1450                  (eq cond-indicator :~))
1451          (let* ((condform (pop opvals)))
1452            (destructuring-bind (cond-name) (cdr condform)
1453              (let* ((p (position cond-name vinsn-params)))
1454                (if p
1455                  (if explicit-cond
1456                    (error "Can't use ~s with explicit condition name." condform)
1457                    (progn
1458                      (add-avi-operand avi (if (eq cond-indicator :?)
1459                                             (encode-vinsn-field-type :cond)
1460                                             (encode-vinsn-field-type :negated-cond))
1461                                       p)
1462                      (setq cond nil)))
1463                  (let* ((c (need-arm-condition-name cond-name)))
1464                    (when (eq cond-indicator :~)
1465                      (if (< c 14)
1466                        (setq c (logxor c 1))
1467                        (error "Invalid explicit condition ~s." condform)))
1468                    (if (and explicit-cond (not (eql c cond)))
1469                      (error "Can't use explicit condition and :? : ~s" condform)
1470                      (setq cond c))))))))
1471        (let* ((optypes (arm-instruction-template-operand-types template))
1472               (n (length optypes)))
1473          (unless (= n (length opvals))
1474            (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form))
1475          (dotimes (i n)
1476            (let* ((optype (pop optypes))
1477                   (opval (pop opvals)))
1478              (funcall (svref *arm-vinsn-operand-parsers* optype)
1479                       avi opval vinsn-params)))
1480          (when cond
1481            (set-avi-opcode-field avi (byte 4 28) cond))
1482          (avi-head avi))))))
1483         
1484
1485
1486(provide "ARM-ASM")
Note: See TracBrowser for help on using the repository browser.