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

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

Back out of uuo-alloc-trap changes.

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