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

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

Keep moving forward. Can -almost- compile simple functions.

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