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

Last change on this file since 13707 was 13707, checked in by gb, 10 years ago

Lots of changes and additions. Seems to work, as far as it goes: still
some missing functionality and likely some bugs, but I don't think that
either of those issues will require massive redesign to address.

File size: 39.0 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 r))))
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-addressing-mode (instruction 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       (set-field-value instruction (byte 1 23) 1))
800     (when (eq mode :+@!)
801       (set-field-value instruction (byte 1 21) 1))
802     (set-field-value instruction (byte 1 24) 1))
803    ((:-@ :-@!)
804     ;; Preindexed. Leave the U bit clear, maybe set W if writeback.
805     (when (eq mode :-@!)
806       (set-field-value instruction (byte 1 21) 1))
807     (set-field-value instruction (byte 1 24) 1))
808    ((:@+ :@-)
809     ;; Postindex; writeback is implicit (and setting P and W would
810     ;; change the instruction.)
811     (unless (or (eq mode :@-) constant-index)
812       (set-field-value instruction (byte 1 23) 1)))))
813
814;;; "general" address operand, as used in LDR/LDRB/STR/STRB
815(defun parse-m12-operand (form instruction)
816  (if (atom form)
817    (error "Invalid memory operand ~s" form)   
818    (let* ((mode (keywordize (car form))))
819      (if (eq mode :=)
820        (destructuring-bind (label) (cdr form)
821          (when (arm::arm-subprimitive-address label)
822            (error "Invalid label in ~s." form))
823          (set-field-value instruction (byte 4 16) arm::pc)
824          (set-field-value instruction (byte 1 24) 1) ;P bit
825          ;; Insert function will have to set U bit appropriately.
826          (lap-note-label-reference label instruction :mem12))
827        (destructuring-bind (rn &optional (index '(:$ 0) index-p)) (cdr form)
828          (unless (or index-p (eq mode :@))
829            (error "missing index in memory operand ~s." form))
830          (set-field-value instruction (byte 4 16) (need-arm-gpr rn))
831          (let* ((quoted (ccl::quoted-form-p index))
832                 (index-op (if quoted :quote (and (consp index) (keywordize (car index)))))
833                 (constant-index (or quoted (eq index-op :$))))
834            (cond (constant-index
835                   (destructuring-bind (val) (cdr index)
836                     (let* ((constval (if quoted
837                                        (need-constant index)
838                                        (eval val))))
839                       (if (< constval 0)
840                         (setq constval (- constval))
841                         ;; das u bit
842                         (set-field-value instruction (byte 1 23) 1))
843                       (unless (typep constval '(unsigned-byte 12))
844                         (warn "constant offset too large : ~s" constval))
845                       (set-field-value instruction (byte 12 0) constval))))
846                  (t
847                   (set-field-value instruction (byte 1 25) 1)
848                   (if (atom index)
849                     (set-field-value instruction (byte 12 0) (need-arm-gpr index))
850                     ;; Shifts here are always by a constant (not another reg)
851                     (if (eq index-op :rrx)
852                       (destructuring-bind (rm) (cdr index)
853                         (set-field-value instruction (byte 12 0)
854                                          (logior (need-arm-gpr rm)
855                                                  (ash (encode-arm-shift-type :ror) 5))))
856                     
857                       (destructuring-bind (rm shift-expr) (cdr index)
858                         (unless (and (consp shift-expr)
859                                      (eq (keywordize (car shift-expr)) :$))
860                           (error "Shift count must be immediate : ~s" shift-expr))
861                         (destructuring-bind (count-expr) (cdr shift-expr)
862                           (set-field-value instruction (byte 12 0)
863                                            (logior (need-arm-gpr rm)
864                                                    (ash (encode-arm-shift-type
865                                                          index-op) 5)
866                                                    (ash (logand 31 (eval count-expr))
867                                                         7)))))))))
868            (set-addressing-mode instruction mode constant-index)))))))
869
870(defun parse-reglist-operand (form instruction)
871  (let* ((mask 0))
872    (dolist (r form)
873      (let* ((regno (need-arm-gpr r)))
874        (when (logbitp regno mask)
875          (warn "Duplicate register ~s in ~s." r form))
876        (setq mask (logior mask (ash 1 regno)))))
877    (if (zerop mask)
878      (error "Empty register list ~s." form)
879      (set-field-value instruction (byte 16 0) mask))))
880
881(defun parse-rnw-operand (form instruction)
882  (if (atom form)
883    (set-field-value instruction (byte 4 16) (need-arm-gpr form))
884    (if (eq (keywordize (car form)) :!)
885      (destructuring-bind (rn) (cdr form)
886        (set-field-value instruction (byte 1 21) 1)
887        (set-field-value instruction (byte 4 16) (need-arm-gpr rn)))
888      (error "Unrecognize writeback indicator in ~s." form))))
889
890(defun parse-uuoA-operand (form instruction)
891  (set-field-value instruction (byte 4 8) (need-arm-gpr form)))
892
893(defun parse-uuo-unary-operand (form instruction)
894  (set-field-value instruction (byte 8 12) (need-constant form)))
895
896(defun parse-uuoB-operand (form instruction)
897  (set-field-value instruction (byte 4 12) (need-arm-gpr form)))
898
899(defun parse-rm-operand (form instruction)
900  (set-field-value instruction (byte 4 0) (need-arm-gpr form)))
901
902(defun parse-b-operand (form instruction)
903  (let* ((address (arm-subprimitive-address form)))
904    (if address
905      (let* ((lab (or (find-lap-label form)
906                      (make-lap-label form))))
907        (pushnew lab *called-subprim-jmp-labels*)
908        (push (cons instruction :b) (lap-label-refs lab)))
909      (lap-note-label-reference form instruction :b))))
910
911(defun parse-subprim-operand (form instruction) 
912  (let* ((address (arm-subprimitive-address form)))
913    (unless address
914      (error "Unknown ARM subprimitive : ~s" form))
915    (set-field-value instruction (byte 12 0) (encode-arm-immediate address))))
916   
917(defun parse-m8-operand (form instruction)
918  (if (atom form)
919    (error "Invalid memory operand ~s." form)
920    (let* ((mode (keywordize (car form)))
921           (constant-index nil))
922      (destructuring-bind (rn index) (cdr form)
923        (set-field-value instruction (byte 4 16) (need-arm-gpr rn))
924        (cond ((atom index)
925               (set-field-value instruction (byte 4 0) (need-arm-gpr index))
926               (set-field-value instruction (byte 25 1) 1))
927              (t (unless (eq (keywordize (car index)) :$)
928                   (error "Invalid index: ~s." index))
929                 (destructuring-bind (val) (cdr index)
930                   (let* ((value (eval val)))
931                     (setq constant-index t)
932                     (if (< value 0)
933                       (setq value (- value))
934                       (set-field-value instruction (byte 23 1) 1))
935                     (set-field-value instruction (byte 4 0) (ldb (byte 4 0) value))
936                     (set-field-value instruction (byte 4 8) (ldb (byte 4 4) value)))))))
937    (set-addressing-mode instruction mode constant-index))))
938       
939                             
940         
941
942(defparameter *arm-operand-parsers*
943    #(parse-rd-operand
944      parse-rn-operand
945      parse-shifter-operand
946      parse-m12-operand
947      parse-reglist-operand
948      parse-rnw-operand
949      parse-uuoa-operand
950      parse-uuo-unary-operand
951      parse-uuob-operand
952      parse-rm-operand
953      parse-b-operand
954      parse-subprim-operand
955      parse-m8-operand
956      ))
957
958
959
960(defun make-lap-instruction (form)
961  (let* ((insn (ccl::alloc-dll-node *lap-instruction-freelist*)))
962    (if (typep insn 'lap-instruction)
963      (progn
964        (setf (lap-instruction-source insn) form
965              (lap-instruction-address insn) nil
966              (lap-instruction-vinsn-info insn) nil
967              (lap-instruction-opcode insn) nil)
968        insn)
969      (%make-lap-instruction form))))
970
971;;; FORM is a list and its car isn't a pseudo-op or lapmacro; try to
972;;; generate an instruction.
973(defun assemble-instruction (seg form)
974  (let* ((insn (make-lap-instruction form)))
975    (destructuring-bind (name . opvals) form
976      (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name)
977        (unless template
978          (error "Unknown ARM instruction - ~s" form))
979        (when (and (consp (car opvals))
980                   (eq (keywordize (caar opvals)) :?))
981          (let* ((condform (pop opvals)))
982            (destructuring-bind (q cond-name) condform
983              (declare (ignore q))
984              (let* ((c (need-arm-condition-name cond-name)))
985                (if (and explicit-cond (not (eql c cond)))
986                  (error "Can't use explicit condition and :? : ~s" condform)
987                  (setq cond c))))))
988        (let* ((optypes (arm-instruction-template-operand-types template))
989               (n (length optypes)))
990          (unless (= n (length opvals))
991            (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form))
992          (setf (lap-instruction-opcode insn)
993                (arm-instruction-template-val template))
994          (dotimes (i n)
995            (let* ((optype (pop optypes))
996                   (val (pop opvals)))
997              (funcall (svref *arm-operand-parsers* optype) val insn)))
998          (when cond
999            (setf (lap-instruction-opcode insn)
1000                  (dpb cond (byte 4 28) (lap-instruction-opcode insn))))
1001          (ccl::append-dll-node insn seg))))))
1002
1003;;; A label can only be emitted once.  Once it's been emitted, its pred/succ
1004;;; slots will be non-nil.
1005
1006(defun lap-label-emitted-p (lab)
1007  (not (null (lap-label-pred lab))))
1008
1009(defun %make-lap-label (name)
1010  (let* ((lab (ccl::alloc-dll-node *lap-label-freelist*)))
1011    (if lab
1012      (progn
1013        (setf (lap-label-address lab) nil
1014              (lap-label-refs lab) nil
1015              (lap-label-name lab) name)
1016        lab)
1017      (%%make-lap-label name))))
1018
1019(defun make-lap-label (name)
1020  (let* ((lab (%make-lap-label name)))
1021    (if (typep *lap-labels* 'hash-table)
1022      (setf (gethash name *lap-labels*) lab)
1023      (progn
1024        (push lab *lap-labels*)
1025        (if (> (length *lap-labels*) 255)
1026          (let* ((hash (make-hash-table :size 512 :test #'eq)))
1027            (dolist (l *lap-labels* (setq *lap-labels* hash))
1028              (setf (gethash (lap-label-name l) hash) l))))))
1029    lab))
1030
1031(defun find-lap-label (name)
1032  (if (typep *lap-labels* 'hash-table)
1033    (gethash name *lap-labels*)
1034    (car (member name *lap-labels* :test #'eq :key #'lap-label-name))))
1035
1036(defun lap-note-label-reference (labx insn type)
1037  (let* ((lab (or (find-lap-label labx)
1038                  (make-lap-label labx))))
1039    (push (cons insn type) (lap-label-refs lab))
1040    lab))
1041
1042(defun emit-lap-label (seg name)
1043  (let* ((lab (find-lap-label name)))
1044    (if  lab 
1045      (when (lap-label-emitted-p lab)
1046        (error "Label ~s: multiply defined." name))
1047      (setq lab (make-lap-label name)))
1048    (ccl::append-dll-node lab seg)))
1049
1050(defmacro do-lap-labels ((lab &optional result) &body body)
1051  (let* ((thunk-name (gensym))
1052         (k (gensym))
1053         (xlab (gensym)))
1054    `(flet ((,thunk-name (,lab) ,@body))
1055      (if (listp *lap-labels*)
1056        (dolist (,xlab *lap-labels*)
1057          (,thunk-name ,xlab))
1058        (maphash #'(lambda (,k ,xlab)
1059                     (declare (ignore ,k))
1060                     (,thunk-name ,xlab))
1061                 *lap-labels*))
1062      ,result)))
1063
1064(defun set-element-addresses (start seg)
1065  (ccl::do-dll-nodes (element seg start)
1066    (setf (instruction-element-address element) start)
1067    (incf start (instruction-element-size element))))
1068
1069(defun count-element-sizes (seg)
1070  (let* ((start 0))
1071    (ccl::do-dll-nodes (element seg start)
1072    (incf start (instruction-element-size element)))))
1073
1074(defun arm-finalize (primary constant-pool)
1075  (dolist (lab *called-subprim-jmp-labels*)
1076    (unless (lap-label-emitted-p lab)
1077      (ccl::append-dll-node lab primary)
1078      (assemble-instruction primary `(ba ,(lap-label-name lab)))))
1079  (let* ((constants-size (count-element-sizes constant-pool)))
1080    (unless (eql constants-size 0)
1081      (let* ((c0 (make-lap-instruction nil)))
1082        (setf (lap-instruction-opcode c0) (ash constants-size -2))
1083        (ccl::insert-dll-node-before c0 (ccl::dll-header-first constant-pool)))))
1084  (let* ((w0 (make-lap-instruction nil))
1085         (w1 (make-lap-instruction nil)))
1086    (setf (lap-instruction-opcode w0) 0)
1087    (ccl::append-dll-node w0 primary)
1088    (ccl::append-dll-node w1 primary )
1089    (let* ((n (set-element-addresses 0 primary)))
1090      (setf (lap-instruction-opcode w1) n)
1091      (set-element-addresses n constant-pool)))
1092  ;; Now fix up label references.  Recall that the PC value at some
1093  ;; point in program execution is 8 bytes beyond that point.
1094  (do-lap-labels (lab)
1095    (if (lap-label-emitted-p lab)
1096      (let* ((labaddr (lap-label-address lab)))
1097        (dolist (ref (lap-label-refs lab))
1098          (destructuring-bind (insn . reftype) ref
1099            (let* ((diff-in-bytes (- labaddr (+ 8 (lap-instruction-address insn)))))
1100              (case reftype
1101                (:b (setf (lap-instruction-opcode insn)
1102                          (dpb (ash diff-in-bytes -2)
1103                               (byte 24 0)
1104                               (lap-instruction-opcode insn))))
1105                (:mem12
1106                 (if (>= diff-in-bytes 0)
1107                   (set-field-value insn (byte 1 23) 1)
1108                   (setq diff-in-bytes (- diff-in-bytes)))
1109                 (set-field-value insn (byte 12 0) diff-in-bytes))
1110                (t
1111                 (error "Label type ~s invalid or not yet supported."
1112                        reftype)))))))
1113      (if (lap-label-refs lab)
1114        (error "LAP label ~s was referenced but not defined." (lap-label-name lab)))))
1115  (ccl::merge-dll-nodes primary constant-pool)
1116  (let* ((last (ccl::dll-header-last primary)))
1117    (ash (+ (instruction-element-address last)
1118            (instruction-element-size last)) -2)))
1119     
1120
1121(provide "ARM-ASM")
Note: See TracBrowser for help on using the repository browser.