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

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

Still changing too much to make changes notable.

File size: 67.2 KB
Line 
1;;;-*- Mode: Lisp; Package: (ARM :use CL) -*-
2;;;
3;;;   Copyright (C) 2005-2009 Clozure Associates and contributors.
4;;;   This file is part of Clozure CL.
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License   known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict  the preamble takes precedence.
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(eval-when (:compile-toplevel :load-toplevel :execute)
18(require "ARM-ARCH")
19)
20
21(in-package "ARM")
22
23(defparameter *arm-condition-names* '(("eq" . 0) ("ne" . 1)
24                                      ("hs" . 2) ("cc" . 2) ("lo" . 3) ("cs" . 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     #x01000000
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     #x0e1000f0
496     ())
497   (define-arm-instruction strd  (:rde :mem8)
498     #x000000f0
499     #x0e4000f0
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     #x0fd00000
514     ())
515   (define-arm-instruction stmia (:rnw :reglist)
516     #x08800000
517     #x0fd00000
518     ())
519   (define-arm-instruction stmea (:rnw :reglist)
520     #x08800000
521     #x0fd00000
522     ())
523   (define-arm-instruction ldmia (:rnw :reglist)
524     #x08900000
525     #x0fd00000
526     ())
527   (define-arm-instruction ldm (:rnw :reglist)
528     #x08900000
529     #x0fd00000
530     ())
531   (define-arm-instruction ldmfd (:rnw :reglist)
532     #x08900000
533     #x0fd00000
534     ())
535   (define-arm-instruction stmdb (:rnw :reglist)
536     #x09000000
537     #x0fd00000
538     ())
539   (define-arm-instruction stmfb (:rnw :reglist)
540     #x09000000
541     #x0fd00000
542     ())
543   (define-arm-instruction stmfd (:rnw :reglist)
544     #x09000000
545     #x0ff00000
546     ())
547   (define-arm-instruction ldmdb (:rnw :reglist)
548     #x09100000
549     #x0fd00000
550     ())
551   (define-arm-instruction ldmea (:rnw :reglist)
552     #x09100000
553     #x0fd00000
554     ())
555
556   (define-arm-instruction b (:b)
557     #x0a000000
558     #x0f000000
559     ())
560   (define-arm-instruction bl (:b)
561     #x0b000000
562     #x0f000000
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   (define-arm-instruction smull (:rd :rn :rm :rn)
663     #x0c000090
664     #x0ff000f0
665     ())
666   (define-arm-instruction smulls (:rd :rn :rm :rn)
667     #x0c000090
668     #x0ff000f0
669     ())   
670   ))
671
672(dotimes (i (length *arm-instruction-table*))
673  (let* ((template (svref *arm-instruction-table* i))
674         (name (arm-instruction-template-name template)))
675    (setf (arm-instruction-template-ordinal template) i
676          (gethash name *arm-instruction-ordinals*) i)))
677
678   
679
680
681
682(defun lookup-arm-instruction (name)
683  ;; return (values instruction template & condition value), or (NIL NIL)
684  (let* ((cond-value #xe)              ;always
685         (string (string name))
686         (len (length string))
687         (ordinal (gethash string *arm-instruction-ordinals*))
688         (template (if ordinal (aref *arm-instruction-table* ordinal))))
689    (if template
690      (values template (unless (logbitp (encode-arm-instruction-flag :non-conditional) (arm-instruction-template-flags template)) cond-value) nil)
691      (if (> len 2)
692        (let* ((cond-name (make-string 2)))
693          (declare (dynamic-extent cond-name))
694          (setf (schar cond-name 0)
695                (schar string (- len 2))
696                (schar cond-name 1)
697                (schar string (- len 1)))
698          (if (setq cond-value (lookup-arm-condition-name cond-name))
699            (let* ((prefix-len (- len 2))
700                   (prefix (make-string prefix-len)))
701              (declare (dynamic-extent prefix)
702                       (fixnum prefix-len))
703              (dotimes (i prefix-len)
704                (setf (schar prefix i) (schar string i)))
705              (if (setq template
706                        (progn
707                          (setq ordinal (gethash prefix *arm-instruction-ordinals*))
708                          (when ordinal
709                            (svref *arm-instruction-table* ordinal))))
710                (if (logbitp (encode-arm-instruction-flag :non-conditional) (arm-instruction-template-flags template))
711                  (values nil nil nil)
712                  (values template cond-value t))
713                (values nil nil nil)))
714            (values nil nil nil)))
715        (values nil nil nil)))))
716
717(defun keywordize (name)
718  (if (typep name 'keyword)
719    name
720    (intern (string-upcase (string name)) "KEYWORD")))
721
722(defun arm-rotate-left (u32 nbits)
723  (assert (and (evenp nbits)
724               (>= nbits 0)
725               (< nbits 32)))
726  (let* ((r (- 32 nbits))
727         (mask (1- (ash 1 nbits))))
728    (logand #xffffffff
729            (logior (ash u32 nbits)
730                    (logand mask
731                            (ash  u32 (- r)))))))
732
733;;; Return a 12-bit value encoding u32 as an 8-bit constant rotated
734;;; by an even number of bits if u32 can be encoded that way, nil
735;;; otherwise.
736(defun encode-arm-immediate (u32)
737  (do* ((u32 (logand #xffffffff u32))
738        (rot 0 (+ rot 2)))
739       ((= rot 32) (values nil nil))
740    (let* ((a (arm-rotate-left u32 rot)))
741      (when (<= a #xff)
742        (return (logior (ash rot 7) a))))))
743
744
745(eval-when (:execute :load-toplevel)
746  (defstruct (instruction-element (:include ccl::dll-node))
747    address
748    (size 0))
749
750;;; A LAP-INSTRUCTION's field-values list contains (byte-spec . value)
751;;; pairs, where the byte-spec is encoded as a fixnum.  If the BYTE-SIZE
752;;; of the byte-spec is non-zero, the value is to be inserted in the
753;;; instruction by DPB; if the BYTE-SIZE is zero, the BYTE-POSITION of
754
755;;; the byte-spec is used to select a function which affects arbitrary
756;;; bitfields in the instruction.  (E.g., a negative constant in an ADD
757;;; instruction might turn the instruction into a SUB.)
758;;; The relationship between logical operands and field-values isn't
759;;; necessarily 1:1.
760;;; For vinsn expansion, the field values with constant values can
761;;; be applied at vinsn-definition time.
762 
763  (defstruct (lap-instruction (:include instruction-element (size 4))
764                              (:constructor %make-lap-instruction (source)))
765    source                              ; for LAP, maybe vinsn-template
766    (opcode 0)
767    vinsn-info                          ;tbd
768    )
769
770   
771  (defstruct (lap-label (:include instruction-element)
772                            (:constructor %%make-lap-label (name)))
773    name
774    refs))
775
776(ccl::def-standard-initial-binding *lap-label-freelist* (ccl::make-dll-node-freelist))
777(ccl::def-standard-initial-binding *lap-instruction-freelist* (ccl::make-dll-node-freelist))
778
779
780(eval-when (:compile-toplevel :execute)
781  (declaim (inline set-field-value)))
782
783(defun set-field-value (instruction bytespec value)
784  (setf (lap-instruction-opcode instruction)
785        (dpb value bytespec (lap-instruction-opcode instruction))))
786
787
788(defun need-arm-gpr (form)
789  (or (get-arm-gpr form)
790      (error "Expected an ARM general-purpose register, got ~s" form)))
791
792(defun need-arm-sfpr (form)
793  (or (get-arm-sfpr form)
794      (error "Expected an ARM single FP register, got ~s" form)))
795
796(defun need-arm-dfpr (form)
797  (or (get-arm-sfpr form)
798      (error "Expected an ARM double FP register, got ~s" form)))
799
800(defun encode-arm-shift-type (op)
801  (case op
802    (:lsl 0)
803    (:lsr 1)
804    (:asr 2)
805    (:ror 3)))
806
807
808(defconstant opcode-and 0)
809(defconstant opcode-eor 1)
810(defconstant opcode-sub 2)
811(defconstant opcode-rsb 3)
812(defconstant opcode-add 4)
813(defconstant opcode-adc 5)
814(defconstant opcode-sbc 6)
815(defconstant opcode-rsc 7)
816(defconstant opcode-tst 8)
817(defconstant opcode-teq 9)
818(defconstant opcode-cmp 10)
819(defconstant opcode-cmn 11)
820(defconstant opcode-orr 12)
821(defconstant opcode-mov 13)
822(defconstant opcode-bic 14)
823(defconstant opcode-mvn 15)
824
825(defvar *equivalent-complemented-opcodes*
826  (vector opcode-bic                    ;and->bic
827          nil                           ;eor->
828          nil                           ;sub->
829          nil                           ;rsb->
830          nil                           ;add->
831          opcode-sbc                    ;adc->sbc
832          opcode-adc                    ;sbc->adc
833          nil                           ;rsc->
834          nil                           ;tst->
835          nil                           ;cmp->
836          nil                           ;cmn->
837          nil                           ;orr->
838          opcode-mvn                    ;mov->mvn
839          opcode-and                    ;bic->and
840          opcode-mov                    ;mvn->mov
841          ))
842
843(defvar *equivalent-negated-opcodes*
844  (vector nil                           ;and->
845          nil                           ;eor->
846          opcode-add                    ;sub->add
847          nil                           ;rsb->
848          opcode-sub                    ;add->sub
849          nil                           ;adc->
850          nil                           ;sbc->
851          nil                           ;rsc->
852          nil                           ;tst->
853          opcode-cmn                    ;cmp->cmn
854          opcode-cmp                    ;cmn->cmp
855          nil                           ;orr->
856          nil                           ;mov->
857          nil                           ;bic->
858          nil                           ;mvn->
859          ))
860
861
862   
863(defun parse-rd-operand (form instruction)
864  (set-field-value instruction (byte 4 12) (need-arm-gpr form)))
865
866(defun parse-rn-operand (form instruction)
867  (set-field-value instruction (byte 4 16) (need-arm-gpr form)))
868
869(defun parse-shifter-operand (form instruction)
870  (if (atom form)
871    ;; rm is shorthand for (:lsl rm (:$ 0)); the :lsl is encoded as 0.
872    (set-field-value instruction (byte 12 0) (need-arm-gpr form))
873    (if (ccl::quoted-form-p form)
874      (insert-shifter-constant (need-constant form) instruction)
875      (let* ((op (keywordize (car form))))
876        (ecase op
877          (:$ (destructuring-bind (value) (cdr form)
878                (insert-shifter-constant (eval value) instruction)))
879          (:rrx (destructuring-bind (reg) (cdr form)
880                  (set-field-value instruction (byte 12 0)
881                                   (logior (need-arm-gpr reg)
882                                           (ash (encode-arm-shift-type :ror) 5)))))
883          ((:lsl :lsr :asr :ror)
884           (destructuring-bind (reg count) (cdr form)
885             (if (atom count)
886               (set-field-value instruction (byte 12 0)
887                                (logior (need-arm-gpr reg)
888                                        (ash 1 4)
889                                        (ash (encode-arm-shift-type op) 5)
890                                        (ash (need-arm-gpr count) 8)))
891               (ecase (keywordize (car count))
892                 (:$ (destructuring-bind (countval) (cdr count)
893                       (set-field-value instruction (byte 12 0)
894                                        (logior (need-arm-gpr reg)
895                                                (ash (encode-arm-shift-type op) 5)
896                                                (ash (logand 31 (eval countval)) 7))))))))))))))
897     
898(defun insert-shifter-constant (value instruction)
899  (let* ((opcode (lap-instruction-opcode instruction))
900         (constant (encode-arm-immediate value)))
901    (setf (lap-instruction-opcode instruction)
902          (if constant
903            (logior constant (logior (ash 1 25) opcode))
904            ;; If value couldn't be encoded but its complement can be
905            ;; and there's an instruction that can operate on complemented
906            ;; values, change the instruction and encode the complemented
907            ;; value.  If that doesn't work, try negating the value and
908            ;; seeing if there's an equivalent instruction that could use
909            ;; that.  If none of this works, complain that the value can't
910            ;; be encoded.
911            (let* ((op (ldb (byte 4 21) opcode))
912                   (newop nil))
913              (if (or (and (setq constant (encode-arm-immediate (lognot value)))
914                           (setq newop (svref *equivalent-complemented-opcodes* op)))
915                      (and (setq constant (encode-arm-immediate (- value)))
916                           (setq newop (svref *equivalent-negated-opcodes* op))))
917                (logior constant
918                        (logior (ash 1 25) (dpb newop (byte 4 21) opcode)))
919                (error "Can't encode ARM constant ~s." value)))))))
920
921(defun set-opcode-value-from-addressing-mode (opcode mode constant-index)
922  ;; Look at mode and set P/W/U bits.  If CONSTANT-INDEX is
923  ;; true, the U bit depends on the sign of the constant.
924  (ecase mode           
925    ((:@ :+@ :+@! :@!)
926     ;; Preindexed, no writeback unless :[+]@! , add register operands.
927     (unless constant-index
928       (setq opcode (logior opcode (ash 1 23))))
929     (when (or (eq mode :+@!)
930               (eq mode :@!))
931       (setq opcode (logior opcode (ash 1 21))))
932     (setq opcode (logior opcode (ash 1 24))))
933    ((:-@ :-@!)
934     ;; Preindexed. Leave the U bit clear, maybe set W if writeback.
935     (when (eq mode :-@!)
936       (setq opcode (logior opcode (ash 1 21))))
937     (setq opcode (logior opcode (ash 1 24))))
938    ((:@+ :@-)
939     ;; Postindex; writeback is implicit (and setting P and W would
940     ;; change the instruction.)
941     (unless (or (eq mode :@-) constant-index)
942       (setq opcode (logior opcode (ash 1 23))))))
943  opcode)
944
945
946(defun set-addressing-mode (instruction mode constant-index)
947  (setf (lap-instruction-opcode instruction)
948        (set-opcode-value-from-addressing-mode
949         (lap-instruction-opcode instruction) mode constant-index)))
950
951;;; "general" address operand, as used in LDR/LDRB/STR/STRB
952(defun parse-m12-operand (form instruction)
953  (if (atom form)
954    (error "Invalid memory operand ~s" form)   
955    (let* ((mode (keywordize (car form))))
956      (if (eq mode :=)
957        (destructuring-bind (label) (cdr form)
958          (when (arm::arm-subprimitive-address label)
959            (error "Invalid label in ~s." form))
960          (set-field-value instruction (byte 4 16) arm::pc)
961          (set-field-value instruction (byte 1 24) 1) ;P bit
962          ;; Insert function will have to set U bit appropriately.
963          (lap-note-label-reference label instruction :mem12))
964        (destructuring-bind (rn &optional (index '(:$ 0) index-p)) (cdr form)
965          (unless (or index-p (eq mode :@))
966            (error "missing index in memory operand ~s." form))
967          (set-field-value instruction (byte 4 16) (need-arm-gpr rn))
968          (let* ((quoted (ccl::quoted-form-p index))
969                 (index-op (if quoted :quote (and (consp index) (keywordize (car index)))))
970                 (constant-index (or quoted (eq index-op :$))))
971            (cond (constant-index
972                   (destructuring-bind (val) (cdr index)
973                     (let* ((constval (if quoted
974                                        (need-constant index)
975                                        (eval val))))
976                       (if (< constval 0)
977                         (setq constval (- constval))
978                         ;; das u bit
979                         (set-field-value instruction (byte 1 23) 1))
980                       (unless (typep constval '(unsigned-byte 12))
981                         (warn "constant offset too large : ~s" constval))
982                       (set-field-value instruction (byte 12 0) constval))))
983                  (t
984                   (set-field-value instruction (byte 1 25) 1)
985                   (if (atom index)
986                     (set-field-value instruction (byte 12 0) (need-arm-gpr index))
987                     ;; Shifts here are always by a constant (not another reg)
988                     (if (eq index-op :rrx)
989                       (destructuring-bind (rm) (cdr index)
990                         (set-field-value instruction (byte 12 0)
991                                          (logior (need-arm-gpr rm)
992                                                  (ash (encode-arm-shift-type :ror) 5))))
993                     
994                       (destructuring-bind (rm shift-expr) (cdr index)
995                         (unless (and (consp shift-expr)
996                                      (eq (keywordize (car shift-expr)) :$))
997                           (error "Shift count must be immediate : ~s" shift-expr))
998                         (destructuring-bind (count-expr) (cdr shift-expr)
999                           (set-field-value instruction (byte 12 0)
1000                                            (logior (need-arm-gpr rm)
1001                                                    (ash (encode-arm-shift-type
1002                                                          index-op) 5)
1003                                                    (ash (logand 31 (eval count-expr))
1004                                                         7)))))))))
1005            (set-addressing-mode instruction mode constant-index)))))))
1006
1007(defun parse-reglist-operand (form instruction)
1008  (let* ((mask 0))
1009    (dolist (r form)
1010      (let* ((regno (need-arm-gpr r)))
1011        (when (logbitp regno mask)
1012          (warn "Duplicate register ~s in ~s." r form))
1013        (setq mask (logior mask (ash 1 regno)))))
1014    (if (zerop mask)
1015      (error "Empty register list ~s." form)
1016      (set-field-value instruction (byte 16 0) mask))))
1017
1018(defun parse-rnw-operand (form instruction)
1019  (if (atom form)
1020    (set-field-value instruction (byte 4 16) (need-arm-gpr form))
1021    (if (eq (keywordize (car form)) :!)
1022      (destructuring-bind (rn) (cdr form)
1023        (set-field-value instruction (byte 1 21) 1)
1024        (set-field-value instruction (byte 4 16) (need-arm-gpr rn)))
1025      (error "Unrecognized writeback indicator in ~s." form))))
1026
1027(defun parse-uuoA-operand (form instruction)
1028  (set-field-value instruction (byte 4 8) (need-arm-gpr form)))
1029
1030(defun parse-uuo-unary-operand (form instruction)
1031  (set-field-value instruction (byte 8 12) (need-constant form)))
1032
1033(defun parse-uuoB-operand (form instruction)
1034  (set-field-value instruction (byte 4 12) (need-arm-gpr form)))
1035
1036(defun parse-rm-operand (form instruction)
1037  (set-field-value instruction (byte 4 0) (need-arm-gpr form)))
1038
1039(defun parse-b-operand (form instruction)
1040  (let* ((address (arm-subprimitive-address form)))
1041    (if address
1042      (let* ((lab (or (find-lap-label form)
1043                      (make-lap-label form))))
1044        (pushnew lab *called-subprim-jmp-labels*)
1045        (push (cons instruction :b) (lap-label-refs lab)))
1046      (lap-note-label-reference form instruction :b))))
1047
1048(defun parse-subprim-operand (form instruction) 
1049  (let* ((address (or (arm-subprimitive-address form)
1050                      (when (arm-subprimitive-name form) form))))
1051    (unless address
1052      (error "Unknown ARM subprimitive : ~s" form))
1053    (set-field-value instruction (byte 12 0) (encode-arm-immediate address))))
1054   
1055(defun parse-m8-operand (form instruction)
1056  (if (atom form)
1057    (error "Invalid memory operand ~s." form)
1058    (let* ((mode (keywordize (car form)))
1059           (constant-index nil))
1060      (destructuring-bind (rn index) (cdr form)
1061        (set-field-value instruction (byte 4 16) (need-arm-gpr rn))
1062        (cond ((atom index)
1063               (set-field-value instruction (byte 4 0) (need-arm-gpr index)))
1064              (t (unless (eq (keywordize (car index)) :$)
1065                   (error "Invalid index: ~s." index))
1066                 (destructuring-bind (val) (cdr index)
1067                   (let* ((value (eval val)))
1068                     (setq constant-index t)
1069                     (if (< value 0)
1070                       (setq value (- value))
1071                       (set-field-value instruction (byte 1 23) 1))
1072                     (set-field-value instruction (byte 1 22) 1)
1073                     (set-field-value instruction (byte 4 0) (ldb (byte 4 0) value))
1074                     (set-field-value instruction (byte 4 8) (ldb (byte 4 4) value)))))))
1075      (set-addressing-mode instruction mode constant-index))))
1076
1077(defun parse-dd-operand (form instruction)
1078  (set-field-value instruction (byte 4 12) (need-arm-dfpr form)))
1079
1080(defun parse-dm-operand (form instruction)
1081  (set-field-value instruction (byte 4 0) (need-arm-dfpr form)))
1082
1083(defun parse-sd-operand (form instruction)
1084  (let* ((val (need-arm-sfpr form)))
1085    (set-field-value instruction (byte 4 12) (ash val -1))
1086    (set-field-value instruction (byte 1 22) (logand val 1))))
1087
1088(defun parse-sm-operand (form instruction)
1089  (let* ((val (need-arm-sfpr form)))
1090    (set-field-value instruction (byte 4 0) (ash val -1))
1091    (set-field-value instruction (byte 1 5) (logand val 1))))
1092
1093(defun parse-dn-operand (form instruction)
1094  (set-field-value instruction (byte 4 16) (need-arm-dfpr form)))       
1095                             
1096(defun parse-sn-operand (form instruction)
1097  (let* ((val (need-arm-sfpr form)))
1098    (set-field-value instruction (byte 4 16) (ash val -1))
1099    (set-field-value instruction (byte 1 7) (logand val 1))))
1100
1101(defun parse-rde-operand (form instruction)
1102  (let* ((val (need-arm-gpr form)))
1103    (when (oddp val)
1104      (error "Register must be even-numbered: ~s." form))
1105    (set-field-value instruction (byte 4 12) val)))
1106
1107(defun parse-rs-operand (form instruction)
1108  (set-field-value instruction (byte 4 8) (need-arm-gpr form)))
1109 
1110(defparameter *arm-operand-parsers*
1111    #(parse-rd-operand
1112      parse-rn-operand
1113      parse-shifter-operand
1114      parse-m12-operand
1115      parse-reglist-operand
1116      parse-rnw-operand
1117      parse-uuoa-operand
1118      parse-uuo-unary-operand
1119      parse-uuob-operand
1120      parse-rm-operand
1121      parse-b-operand
1122      parse-subprim-operand
1123      parse-m8-operand
1124      parse-dd-operand
1125      parse-dm-operand
1126      parse-sd-operand
1127      parse-sm-operand
1128      parse-dn-operand
1129      parse-sn-operand
1130      parse-rde-operand
1131      parse-rs-operand
1132      ))
1133
1134
1135
1136(defun make-lap-instruction (form)
1137  (let* ((insn (ccl::alloc-dll-node *lap-instruction-freelist*)))
1138    (if (typep insn 'lap-instruction)
1139      (progn
1140        (setf (lap-instruction-source insn) form
1141              (lap-instruction-address insn) nil
1142              (lap-instruction-vinsn-info insn) nil
1143              (lap-instruction-opcode insn) nil)
1144        insn)
1145      (%make-lap-instruction form))))
1146
1147;;; FORM is a list and its car isn't a pseudo-op or lapmacro; try to
1148;;; generate an instruction.
1149(defun assemble-instruction (seg form)
1150  (let* ((insn (make-lap-instruction form)))
1151    (destructuring-bind (name . opvals) form
1152      (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name)
1153        (unless template
1154          (error "Unknown ARM instruction - ~s" form))
1155        (let* ((cond-indicator (and (consp (car opvals))
1156                                    (keywordize (caar opvals)))))
1157          (when (or (eq cond-indicator :?)
1158                    (eq cond-indicator :~))
1159            (let* ((condform (pop opvals)))
1160              (destructuring-bind (q cond-name) condform
1161                (declare (ignore q))
1162                (let* ((c (need-arm-condition-name cond-name)))
1163                  (when (eq cond-indicator :~)
1164                    (if (< c 14)
1165                      (setq c (logxor c 1))
1166                      (error "Invalid explicit condition ~s." condform)))
1167                  (if (and explicit-cond (not (eql c cond)))
1168                    (error "Can't use explicit condition and :? : ~s" condform)
1169                    (setq cond c)))))))
1170        (let* ((optypes (arm-instruction-template-operand-types template))
1171               (n (length optypes)))
1172          (unless (= n (length opvals))
1173            (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form))
1174          (setf (lap-instruction-opcode insn)
1175                (arm-instruction-template-val template))
1176          (dotimes (i n)
1177            (let* ((optype (pop optypes))
1178                   (val (pop opvals)))
1179              (funcall (svref *arm-operand-parsers* optype) val insn)))
1180          (when cond
1181            (setf (lap-instruction-opcode insn)
1182                  (dpb cond (byte 4 28) (lap-instruction-opcode insn))))
1183          (ccl::append-dll-node insn seg))))))
1184
1185;;; A label can only be emitted once.  Once it's been emitted, its pred/succ
1186;;; slots will be non-nil.
1187
1188(defun lap-label-emitted-p (lab)
1189  (not (null (lap-label-pred lab))))
1190
1191(defun %make-lap-label (name)
1192  (let* ((lab (ccl::alloc-dll-node *lap-label-freelist*)))
1193    (if lab
1194      (progn
1195        (setf (lap-label-address lab) nil
1196              (lap-label-refs lab) nil
1197              (lap-label-name lab) name)
1198        lab)
1199      (%%make-lap-label name))))
1200
1201(defun make-lap-label (name)
1202  (let* ((lab (%make-lap-label name)))
1203    (if (typep *lap-labels* 'hash-table)
1204      (setf (gethash name *lap-labels*) lab)
1205      (progn
1206        (push lab *lap-labels*)
1207        (if (> (length *lap-labels*) 255)
1208          (let* ((hash (make-hash-table :size 512 :test #'eq)))
1209            (dolist (l *lap-labels* (setq *lap-labels* hash))
1210              (setf (gethash (lap-label-name l) hash) l))))))
1211    lab))
1212
1213(defun find-lap-label (name)
1214  (if (typep *lap-labels* 'hash-table)
1215    (gethash name *lap-labels*)
1216    (car (member name *lap-labels* :test #'eq :key #'lap-label-name))))
1217
1218(defun lap-note-label-reference (labx insn type)
1219  (let* ((lab (or (find-lap-label labx)
1220                  (make-lap-label labx))))
1221    (push (cons insn type) (lap-label-refs lab))
1222    lab))
1223
1224(defun emit-lap-label (seg name)
1225  (let* ((lab (find-lap-label name)))
1226    (if  lab 
1227      (when (lap-label-emitted-p lab)
1228        (error "Label ~s: multiply defined." name))
1229      (setq lab (make-lap-label name)))
1230    (ccl::append-dll-node lab seg)))
1231
1232(defmacro do-lap-labels ((lab &optional result) &body body)
1233  (let* ((thunk-name (gensym))
1234         (k (gensym))
1235         (xlab (gensym)))
1236    `(flet ((,thunk-name (,lab) ,@body))
1237      (if (listp *lap-labels*)
1238        (dolist (,xlab *lap-labels*)
1239          (,thunk-name ,xlab))
1240        (maphash #'(lambda (,k ,xlab)
1241                     (declare (ignore ,k))
1242                     (,thunk-name ,xlab))
1243                 *lap-labels*))
1244      ,result)))
1245
1246(defun set-element-addresses (start seg)
1247  (ccl::do-dll-nodes (element seg start)
1248    (setf (instruction-element-address element) start)
1249    (incf start (instruction-element-size element))))
1250
1251(defun count-element-sizes (seg)
1252  (let* ((start 0))
1253    (ccl::do-dll-nodes (element seg start)
1254    (incf start (instruction-element-size element)))))
1255
1256(defun arm-finalize (primary constant-pool)
1257  (do-lap-labels (lab)
1258    (loop
1259      (when (dolist (ref (lap-label-refs lab) t)
1260              (when (eq lab (lap-instruction-succ (car ref)))
1261                (ccl::remove-dll-node (car ref))
1262                (setf (lap-label-refs lab)
1263                      (delete ref (lap-label-refs lab)))
1264                (return)))
1265        (return))))
1266  (dolist (lab *called-subprim-jmp-labels*)
1267    (unless (lap-label-emitted-p lab)
1268      (ccl::append-dll-node lab primary)
1269      (assemble-instruction primary `(ba ,(lap-label-name lab)))))
1270  (let* ((constants-size (count-element-sizes constant-pool)))
1271    (unless (eql constants-size 0)
1272      (let* ((c0 (make-lap-instruction nil)))
1273        (setf (lap-instruction-opcode c0) (ash constants-size -2))
1274        (ccl::insert-dll-node-before c0 (ccl::dll-header-first constant-pool)))))
1275  (let* ((w0 (make-lap-instruction nil))
1276         (w1 (make-lap-instruction nil)))
1277    (setf (lap-instruction-opcode w0) 0)
1278    (ccl::append-dll-node w0 primary)
1279    (ccl::append-dll-node w1 primary )
1280    (let* ((n (set-element-addresses 0 primary)))
1281      (setf (lap-instruction-opcode w1) (ash n (- arm::word-shift)))
1282      (set-element-addresses n constant-pool)))
1283  ;; Now fix up label references.  Recall that the PC value at some
1284  ;; point in program execution is 8 bytes beyond that point.
1285  (do-lap-labels (lab)
1286    (if (lap-label-emitted-p lab)
1287      (let* ((labaddr (lap-label-address lab)))
1288        (dolist (ref (lap-label-refs lab))
1289          (destructuring-bind (insn . reftype) ref
1290            (let* ((diff-in-bytes (- labaddr (+ 8 (lap-instruction-address insn)))))
1291              (case reftype
1292                (:b (setf (lap-instruction-opcode insn)
1293                          (dpb (ash diff-in-bytes -2)
1294                               (byte 24 0)
1295                               (lap-instruction-opcode insn))))
1296                (:mem12
1297                 (if (>= diff-in-bytes 0)
1298                   (set-field-value insn (byte 1 23) 1)
1299                   (setq diff-in-bytes (- diff-in-bytes)))
1300                 (set-field-value insn (byte 12 0) diff-in-bytes))
1301                (t
1302                 (error "Label type ~s invalid or not yet supported."
1303                        reftype)))))))
1304      (if (lap-label-refs lab)
1305        (error "LAP label ~s was referenced but not defined." (lap-label-name lab)))))
1306  (ccl::merge-dll-nodes primary constant-pool)
1307  (let* ((last (ccl::dll-header-last primary)))
1308    (ash (+ (instruction-element-address last)
1309            (instruction-element-size last)) -2)))
1310
1311;;; We want to be able to write vinsn templates using a (mostly) LAP-like
1312;;; syntax, but ideally don't want to have to repeatedly expand those
1313;;; vinsn-definition-time-invariant elements of that syntax.
1314;;;
1315;;; For example, if DEST is a vinsn parameter and the vinsn body
1316;;; contains:
1317;;;
1318;;;   (ldr DEST (:@ rcontext (:$ arm::tcr.db-link)))
1319;;;
1320;;; then we know at definition time:
1321;;;  1) the opcode of the LDR instruction (obviously)
1322;;;  2) the fact that the LDR's :mem12 operand uses indexed
1323;;;     addressing with an immediate operand and no writeback
1324;;;  3) in this example, we also know the value of the RB field
1325;;;     and the value of the immediate operand, which happens
1326;;;     to be positive (setting the U bit).
1327;;;
1328;;;  We can apply this knowledge at definition time, and set
1329;;;  the appropriate bits (U, RN, IMM12) in the opcode.
1330;;;
1331;;;  We don't, of course, know the value of DEST at vinsn-definition
1332;;;  time, but we do know that it's the Nth vinsn parameter, so we
1333;;;  can turn this example into something like:
1334;;;
1335;;;  `(,(augmented-opcode-for-LDR) #(rd-field) #(index-of-DEST)
1336;;;
1337;;; This is defined here (rather than in the compiler backend) since
1338;;; it needs to know a lot about ARM instruction encoding.
1339
1340(defstruct (arm-vinsn-instruction (:constructor %make-arm-vinsn-instruction)
1341                                  (:conc-name avi-))
1342  head
1343  tail)
1344
1345(defun make-arm-vinsn-instruction (opcode)
1346  (let* ((head (list opcode)))
1347    (%make-arm-vinsn-instruction :head head :tail head)))
1348
1349(defun add-avi-operand (instruction field-type value)
1350  (let* ((tail (avi-tail instruction)))
1351    (setf (avi-tail instruction)
1352          (cdr (rplacd tail (cons (cons field-type value) nil))))))
1353
1354(defun avi-opcode (avi)
1355  (car (avi-head avi)))
1356
1357(defun (setf avi-opcode) (new avi)
1358  (setf (car (avi-head avi)) new))
1359
1360(defun set-avi-opcode-field (avi bytespec value)
1361  (setf (avi-opcode avi)
1362        (dpb value bytespec (avi-opcode avi)))
1363  value)
1364
1365
1366(eval-when (:compile-toplevel :load-toplevel :execute)
1367(defparameter *vinsn-field-types*
1368  #(:cond
1369    :negated-cond
1370    :rn
1371    :rd
1372    :rm
1373    :rs
1374    :alu-constant
1375    :shift-count                        ;shift type is always explicit
1376    :mem12-offset
1377    :mem8-offset
1378    :reglist-bit
1379    :uuoA
1380    :uuo-unary
1381    :uuoB
1382    :label
1383    :subprim
1384    :data-label
1385    :dd
1386    :dm
1387    :sd
1388    :sm
1389    :dn
1390    :sn
1391    )))
1392
1393(defmacro encode-vinsn-field-type (name)
1394  (or (position name *vinsn-field-types*)
1395      (error "Unknown vinsn-field-type name ~s." name)))
1396
1397(defparameter *arm-vinsn-operand-parsers*
1398    #(vinsn-parse-rd-operand
1399      vinsn-parse-rn-operand
1400      vinsn-parse-shifter-operand
1401      vinsn-parse-m12-operand
1402      vinsn-parse-reglist-operand
1403      vinsn-parse-rnw-operand
1404      vinsn-parse-uuoa-operand
1405      vinsn-parse-uuo-unary-operand
1406      vinsn-parse-uuob-operand
1407      vinsn-parse-rm-operand
1408      vinsn-parse-b-operand
1409      vinsn-parse-subprim-operand
1410      vinsn-parse-m8-operand
1411      vinsn-parse-dd-operand
1412      vinsn-parse-dm-operand
1413      vinsn-parse-sd-operand
1414      vinsn-parse-sm-operand
1415      vinsn-parse-dn-operand
1416      vinsn-parse-sn-operand
1417      vinsn-parse-rde-operand
1418      vinsn-parse-rs-operand
1419      ))
1420
1421(defun vinsn-arg-or-gpr (avi form vinsn-params encoded-type bytespec)
1422  (let* ((p (position form vinsn-params)))
1423    (cond (p
1424           (add-avi-operand avi encoded-type (list p))
1425           nil)
1426          (t           
1427           (set-avi-opcode-field avi bytespec (need-arm-gpr form))))))
1428
1429(defun vinsn-arg-or-dfpr (avi form vinsn-params encoded-type bytespec)
1430  (let* ((p (position form vinsn-params)))
1431    (cond (p
1432           (add-avi-operand avi encoded-type (list p))
1433           nil)
1434          (t           
1435           (set-avi-opcode-field avi bytespec (need-arm-dfpr form))))))
1436
1437(defun vinsn-arg-or-sfpr (avi form vinsn-params encoded-type top4 low1)
1438  (let* ((p (position form vinsn-params)))
1439    (cond (p
1440           (add-avi-operand avi encoded-type (list p))
1441           nil)
1442          (t
1443           (let* ((val (need-arm-sfpr form)))
1444             (set-avi-opcode-field avi top4 (ash val -1))
1445             (set-avi-opcode-field avi low1 (logand val 1)))))))
1446
1447(defun simplify-arm-vinsn-application (form params)
1448  (labels ((simplify-operand (op)
1449             (if (atom op)
1450               (if (typep form 'fixnum)
1451                 op
1452                 (if (constantp op)
1453                   (eval op)
1454                   (let* ((p (position op params)))
1455                     (if p
1456                       (list p)
1457                       (error "Unknown operand: ~s" op)))))
1458               (if (eq (car op) :apply)
1459                 `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op)))
1460                 (eval op)))))
1461    `(,(cadr form) ,@(mapcar #'simplify-operand (cddr form)))))
1462
1463(defun vinsn-arg-or-constant (avi form vinsn-params encoded-type bytespec)
1464  (let* ((p (position form vinsn-params)))
1465    (cond (p
1466           (add-avi-operand avi encoded-type (list p))
1467           nil)
1468          ((and (typep form 'keyword)
1469                (eql encoded-type (encode-vinsn-field-type :mem12-offset)))
1470           (add-avi-operand avi (encode-vinsn-field-type :data-label) form)
1471           nil)
1472          ((and (consp form) (eq (car form) :apply))
1473           (add-avi-operand avi encoded-type (simplify-arm-vinsn-application form vinsn-params))
1474           nil)
1475          (t
1476           (let* ((val (eval form)))
1477             (when bytespec
1478               (set-avi-opcode-field avi bytespec val))
1479             val)))))
1480
1481
1482
1483(defun vinsn-parse-rd-operand (avi value vinsn-params)
1484  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rd) (byte 4 12)))
1485
1486(defun vinsn-parse-rn-operand (avi value vinsn-params)
1487  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rn) (byte 4 16)))
1488
1489(defun vinsn-parse-shifter-operand (avi value vinsn-params)
1490  (if (atom value)
1491    (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1492    (ecase (car value)
1493      (:$
1494       (destructuring-bind (v) (cdr value)
1495         (let* ((val (vinsn-arg-or-constant avi v vinsn-params (encode-vinsn-field-type :alu-constant) nil)))
1496           (when val
1497             (let* ((constant (encode-arm-immediate val)))
1498               (if constant
1499                 (progn
1500                   (set-avi-opcode-field avi (byte 1 25) 1)
1501                   (set-avi-opcode-field avi (byte 12 0) constant))
1502                 (let* ((op (ldb (byte 4 21) (avi-opcode avi)))
1503                        (newop nil))
1504                   (if (or (and (setq constant (encode-arm-immediate (lognot val)))
1505                                (setq newop (svref *equivalent-complemented-opcodes* op)))
1506                           (and (setq constant (encode-arm-immediate (- val)))
1507                                (setq newop (svref *equivalent-negated-opcodes* op))))
1508                     (progn
1509                       (set-avi-opcode-field avi (byte 1 25) 1)
1510                       (set-avi-opcode-field avi (byte 4 21) newop)
1511                       (set-avi-opcode-field avi (byte 12 0) constant))
1512                     
1513                     (error "Can't encode ARM constant ~s." value)))))))))
1514      (:rrx
1515       (destructuring-bind (rm) (cdr value)
1516         (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1517         (set-avi-opcode-field avi (byte 2 5) 3)))
1518      ((:lsl :lsr :asr :ror)
1519       (destructuring-bind (rm count) (cdr value)
1520         (set-avi-opcode-field avi (byte 2 5) (encode-arm-shift-type (car value)))
1521         (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1522         (cond
1523           ((atom count)
1524            (set-avi-opcode-field avi (byte 1 4) 1)
1525            (vinsn-arg-or-gpr avi count vinsn-params (encode-vinsn-field-type :rs) (byte 4 8)))
1526           (t
1527            (unless (eq (car count) :$)
1528              (error "Invalid shift count: ~s" count))
1529            (destructuring-bind (countval) (cdr count)
1530              (vinsn-arg-or-constant avi countval vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7))))))))))
1531
1532(defun vinsn-parse-m12-operand (avi value vinsn-params)
1533  (when (typep value 'keyword)
1534    (setq value `(:@ arm::pc (:$ ,value))))
1535  (destructuring-bind (op rn index) value     ; no (:@ reg) sugar
1536    (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16))
1537    (let* ((constant-index (and (consp index) (eq (car index) :$))))
1538      (unless constant-index
1539        (set-avi-opcode-field avi (byte 1 25) 1))
1540      (cond
1541        ((atom index)
1542         (vinsn-arg-or-gpr avi index vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)))
1543        (constant-index
1544         (destructuring-bind (constform) (cdr index)
1545           (let* ((constval
1546                   (vinsn-arg-or-constant avi constform vinsn-params (encode-vinsn-field-type :mem12-offset) nil)))
1547             (when constval
1548               (if (< constval 0)
1549                 (setq constval (- constval))
1550                 (set-avi-opcode-field avi (byte 1 23) 1))
1551               (unless (typep constval '(unsigned-byte 12))
1552                 (warn "constant offset too large : ~s" constval))
1553               (set-avi-opcode-field avi (byte 12 0) constval)))))
1554        ((eq (car index) :rrx)
1555         (destructuring-bind (rm) (cdr index)
1556           (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1557           (set-avi-opcode-field avi (byte 2 5) 3)))
1558        (t
1559         (destructuring-bind (shift-op rm shift-count) index
1560           (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1561           (set-avi-opcode-field avi (byte 2 5) (encode-arm-shift-type shift-op))
1562
1563           (unless (and (consp shift-count)
1564                        (eq (car shift-count) :$))
1565             (error "Invalid shift-count: ~s" shift-count))
1566           (destructuring-bind (shift-count-form) (cdr shift-count)
1567             (vinsn-arg-or-constant avi shift-count-form vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7))))))
1568      (setf (avi-opcode avi)
1569            (set-opcode-value-from-addressing-mode (avi-opcode avi) op constant-index)))))
1570
1571(defun vinsn-parse-reglist-operand (avi value vinsn-params)
1572  (dolist (r value)
1573    (let* ((p (position r vinsn-params)))
1574      (if p
1575        (add-avi-operand avi (encode-vinsn-field-type :reglist-bit) (list p))
1576        (let* ((bit (need-arm-gpr r)))
1577          (setf (avi-opcode avi)
1578                (logior (avi-opcode avi) (ash 1 bit))))))))
1579
1580(defun vinsn-parse-rnw-operand (avi value vinsn-params)
1581  (let* ((rn (if (atom value)
1582               value
1583               (destructuring-bind (marker reg) value
1584                 (if (eq marker :!)
1585                   (set-avi-opcode-field avi (byte 1 21) 1)
1586                   (error "Unrecognized writeback indicator in ~s." value))
1587                 reg))))
1588    (vinsn-arg-or-gpr avi rn vinsn-params  (encode-vinsn-field-type :rn) (byte 4 16))))
1589
1590(defun vinsn-parse-uuoA-operand (avi value vinsn-params)
1591  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :uuoA) (byte 4 8)))
1592
1593(defun vinsn-parse-uuo-unary-operand (avi value vinsn-params)
1594  (when (or (atom value)
1595          (not (eq (car value) :$)))
1596    (error "Invalid constant syntax in ~s." value))
1597  (destructuring-bind (valform) (cdr value)
1598    (vinsn-arg-or-constant avi valform vinsn-params (encode-vinsn-field-type :uuo-unary) (byte 8 12))))
1599
1600(defun vinsn-parse-uuoB-operand (avi value vinsn-params)
1601  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :uuoB) (byte 4 12)))
1602
1603(defun vinsn-parse-rm-operand (avi value vinsn-params)
1604  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)))
1605
1606(defun vinsn-parse-b-operand (avi value vinsn-params)
1607  ;; Pretty much has to be a param or a local label what else would we b to ?
1608  (let* ((p (position value vinsn-params))
1609         (addr nil))
1610    (cond (p
1611           (add-avi-operand avi (encode-vinsn-field-type :label) (list p)))
1612          ((typep value 'keyword)
1613           (add-avi-operand avi (encode-vinsn-field-type :label) value))
1614          ((setq addr (arm-subprimitive-address value))
1615           (add-avi-operand avi (encode-vinsn-field-type :label) addr))
1616          ((arm-subprimitive-name value)
1617           (add-avi-operand avi (encode-vinsn-field-type :label) value))
1618          (t
1619           (error "Unknown branch target: ~s." value)))))
1620
1621;;; This can only appear in a BA (mov PC,(:$ addr)) instruction, which
1622;;; already has bit 25 set.
1623(defun vinsn-parse-subprim-operand (avi value vinsn-params)
1624  (let* ((p (position value vinsn-params)))
1625    (if p
1626      (add-avi-operand avi (encode-vinsn-field-type :subprim) (list p))
1627      (let* ((addr (or (arm-subprimitive-address value)
1628                   (and (typep value 'integer)
1629                        (>= value #x4000)
1630                        (< value #x10000)
1631                        (not (logtest #x7f value))))))
1632        (unless addr
1633          (error "Unknown ARM subprimitive address: ~s." value))
1634        (set-avi-opcode-field avi (byte 12 0) (encode-arm-immediate addr))))))
1635
1636(defun vinsn-parse-m8-operand (avi value vinsn-params)
1637  (if (atom value)
1638    (error "Invalid memory operand ~s." value)
1639    (destructuring-bind (mode rn index) value
1640      (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16))
1641      (let* ((constant-index (and (consp index) (eq (car index) :$))))
1642        (when constant-index
1643          (set-avi-opcode-field avi (byte 1 22) 1))
1644        (cond ((atom index)
1645               (vinsn-arg-or-gpr avi index vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)))
1646              (constant-index
1647               (destructuring-bind (constform) (cdr index)
1648                 (let* ((constval
1649                         (vinsn-arg-or-constant avi constform vinsn-params (encode-vinsn-field-type :mem8-offset) nil)))
1650                   (when constval
1651                     (if (< constval 0)
1652                       (setq constval (- constval))
1653                       (set-avi-opcode-field avi (byte 1 23) 1))
1654                     (unless (typep constval '(unsigned-byte 8))
1655                       (warn "constant offset too large : ~s" constval))
1656                     (set-avi-opcode-field avi (byte 4 0) (ldb (byte 4 0) constval))
1657                     (set-avi-opcode-field avi (byte 4 8) (ldb (byte 4 4) constval))))))
1658              ((eq (car index) :rrx)
1659               (destructuring-bind (rm) (cdr index)
1660                 (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1661                 (set-avi-opcode-field avi (byte 2 5) 3)))
1662              (t
1663               (destructuring-bind (shift-op rm shift-count) index
1664                 (vinsn-arg-or-gpr avi rm vinsn-params (encode-vinsn-field-type :rm) (byte 4 0))
1665                 (set-avi-opcode-field avi (byte 2 5) (encode-arm-shift-type shift-op))
1666                 (unless (and (consp shift-count)
1667                              (eq (car shift-count) :$))
1668                   (error "Invalid shift-count: ~s" shift-count))
1669                 (destructuring-bind (shift-count-form) (cdr shift-count)
1670                   (vinsn-arg-or-constant avi shift-count-form vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7))))))
1671        (setf (avi-opcode avi)
1672              (set-opcode-value-from-addressing-mode (avi-opcode avi) mode constant-index))))))
1673
1674(defun vinsn-parse-dd-operand (avi value vinsn-params)
1675  (vinsn-arg-or-dfpr avi value vinsn-params (encode-vinsn-field-type :dd) (byte 4 12)))
1676
1677(defun vinsn-parse-dm-operand (avi value vinsn-params)
1678  (vinsn-arg-or-dfpr avi value vinsn-params (encode-vinsn-field-type :dm) (byte 4 0)))
1679
1680(defun vinsn-parse-sd-operand (avi value vinsn-params)
1681  (vinsn-arg-or-sfpr avi value vinsn-params (encode-vinsn-field-type :sd) (byte 4 12) (byte 1 22)))
1682
1683(defun vinsn-parse-sm-operand (avi value vinsn-params)
1684  (vinsn-arg-or-sfpr avi value vinsn-params (encode-vinsn-field-type :sm) (byte 4 0) (byte 1 5)))
1685
1686(defun vinsn-parse-dn-operand (avi value vinsn-params)
1687  (vinsn-arg-or-dfpr avi value vinsn-params (encode-vinsn-field-type :dn) (byte 4 16)))
1688
1689(defun vinsn-parse-sn-operand (avi value vinsn-params)
1690  (vinsn-arg-or-sfpr avi value vinsn-params (encode-vinsn-field-type :sn) (byte 4 16) (byte 1 7)))
1691
1692(defun vinsn-parse-rde-operand (avi value vinsn-params)
1693  (let* ((val (get-arm-gpr value)))
1694    (when (and val (oddp val))
1695      (error "Register ~s must be even-numbered." value)))
1696  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rd) (byte 4 12)))
1697
1698(defun vinsn-parse-rs-operand (avi value vinsn-params)
1699  (vinsn-arg-or-gpr avi value vinsn-params (encode-vinsn-field-type :rs) (byte 4 8)))
1700
1701(defun vinsn-simplify-instruction (form vinsn-params)
1702  (destructuring-bind (name . opvals) form
1703    (case name
1704      ((:code :data) form)
1705      (:word (destructuring-bind (val) opvals
1706               (let* ((p (position val vinsn-params)))
1707                 (list name (if p (list p) (eval val))))))
1708      (t
1709       (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name)
1710         (unless template
1711           (error "Unknown ARM instruction - ~s" form))
1712         (let* ((cond-indicator (and (consp (car opvals))
1713                                     (keywordize (caar opvals))))
1714                (avi (make-arm-vinsn-instruction (arm-instruction-template-val template))))
1715           (when (or (eq cond-indicator :?)
1716                     (eq cond-indicator :~))
1717             (let* ((condform (pop opvals)))
1718               (destructuring-bind (cond-name) (cdr condform)
1719                 (let* ((p (position cond-name vinsn-params)))
1720                   (if p
1721                     (if explicit-cond
1722                       (error "Can't use ~s with explicit condition name." condform)
1723                       (progn
1724                         (add-avi-operand avi (if (eq cond-indicator :?)
1725                                                (encode-vinsn-field-type :cond)
1726                                                (encode-vinsn-field-type :negated-cond))
1727                                          (list p))
1728                         (setq cond nil)))
1729                     (let* ((c (need-arm-condition-name cond-name)))
1730                       (when (eq cond-indicator :~)
1731                         (if (< c 14)
1732                           (setq c (logxor c 1))
1733                           (error "Invalid explicit condition ~s." condform)))
1734                       (if (and explicit-cond (not (eql c cond)))
1735                         (error "Can't use explicit condition and :? : ~s" condform)
1736                         (setq cond c))))))))
1737           (let* ((optypes (arm-instruction-template-operand-types template))
1738                  (n (length optypes)))
1739             (unless (= n (length opvals))
1740               (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form))
1741             (dotimes (i n)
1742               (let* ((optype (pop optypes))
1743                      (opval (pop opvals)))
1744                 (funcall (svref *arm-vinsn-operand-parsers* optype)
1745                          avi opval vinsn-params)))
1746             (when cond
1747               (set-avi-opcode-field avi (byte 4 28) cond))
1748             (avi-head avi))))))))
1749         
1750
1751(defparameter *arm-vinsn-insert-functions*
1752  #(vinsn-insert-cond-operand
1753    vinsn-insert-negated-cond-operand
1754    vinsn-insert-rn-operand
1755    vinsn-insert-rd-operand
1756    vinsn-insert-rm-operand
1757    vinsn-insert-rs-operand
1758    vinsn-insert-alu-constant-operand
1759    vinsn-insert-shift-count-operand                        ;shift type is always explicit
1760    vinsn-insert-mem12-offset-operand
1761    vinsn-insert-mem8-offset-operand
1762    vinsn-insert-reglist-bit-operand
1763    vinsn-insert-uuoA-operand
1764    vinsn-insert-uuo-unary-operand
1765    vinsn-insert-uuoB-operand
1766    vinsn-insert-label-operand
1767    vinsn-insert-subprim-operand
1768    vinsn-insert-data-label-operand
1769    vinsn-insert-dd-operand
1770    vinsn-insert-dm-operand
1771    vinsn-insert-sd-operand
1772    vinsn-insert-sm-operand
1773    vinsn-insert-dn-operand
1774    vinsn-insert-sn-operand
1775    ))
1776
1777(defun vinsn-insert-cond-operand (instruction value)
1778  (set-field-value instruction (byte 4 28) value))
1779
1780(defun vinsn-insert-negated-cond-operand (instruction value)
1781  (set-field-value instruction (byte 4 28) (logxor value 1)))
1782
1783(defun vinsn-insert-rn-operand (instruction value)
1784  (set-field-value instruction (byte 4 16) value))
1785
1786(defun vinsn-insert-rd-operand (instruction value)
1787  (set-field-value instruction (byte 4 12) value))
1788
1789(defun vinsn-insert-rm-operand (instruction value)
1790  (set-field-value instruction (byte 4 0) value))
1791
1792(defun vinsn-insert-rs-operand (instruction value)
1793  (set-field-value instruction (byte 4 8) value))
1794
1795(defun vinsn-insert-alu-constant-operand (instruction value)
1796  (insert-shifter-constant value instruction))
1797
1798(defun vinsn-insert-shift-count-operand (instruction value)
1799  (set-field-value instruction (byte 5 7) value))
1800
1801(defun vinsn-insert-mem12-offset-operand (instruction value)
1802  (if (typep value 'lap-label)
1803    (lap-note-label-reference value instruction :mem12)
1804    (progn
1805      (if (< value 0)
1806        (setq value (- value))
1807        (set-field-value instruction (byte 1 23) 1))
1808      (set-field-value instruction (byte 12 0) value))))
1809
1810(defun vinsn-insert-mem8-offset-operand (instruction value) 
1811  (if (< value 0)
1812    (setq value (- value))
1813    (set-field-value instruction (byte 1 23) 1))
1814  (set-field-value instruction (byte 4 8) (ldb (byte 4 4) value))
1815  (set-field-value instruction (byte 4 0) (ldb (byte 4 0) value)))
1816
1817(defun vinsn-insert-reglist-bit-operand (instruction value)
1818  (set-field-value instruction (byte 1 value) 1))
1819
1820(defun vinsn-insert-uuoA-operand (instruction value)
1821  (set-field-value instruction (byte 4 8) value))
1822
1823(defun vinsn-insert-uuo-unary-operand (instruction value)
1824  (set-field-value instruction (byte 8 12) value))
1825
1826(defun vinsn-insert-uuoB-operand (instruction value)
1827  (set-field-value instruction (byte 4 12) value))
1828
1829(defun vinsn-insert-label-operand (instruction value)
1830  (let* ((label (etypecase value
1831                  (cons (or (find-lap-label value)
1832                            (error "No LAP label for ~s." (car value))))
1833                  (lap-label value)
1834                  (ccl::vinsn-label
1835                   (or (find-lap-label value)
1836                       (make-lap-label value)))
1837                  (fixnum (let* ((lab (or (find-lap-label value)
1838                                          (make-lap-label value))))
1839                            (pushnew lab *called-subprim-jmp-labels*)
1840                            lab)))))
1841    (push (cons instruction :b) (lap-label-refs label))))
1842
1843(defun vinsn-insert-subprim-operand (instruction value)
1844  )
1845
1846(defun vinsn-insert-data-label-operand (instruction value)
1847  (let* ((label (if (typep value 'lap-label) value (find-lap-label value))))
1848    (unless label
1849      (error "Mystery data label: ~s" value))
1850    (push (cons instruction :mem12) (lap-label-refs label))))
1851
1852(defun vinsn-insert-dd-operand (instruction value)
1853  (set-field-value instruction (byte 4 12) value) )
1854
1855(defun vinsn-insert-dm-operand (instruction value)
1856  (set-field-value instruction (byte 4 0) value))
1857
1858(defun vinsn-insert-sd-operand (instruction value)
1859  )
1860
1861(defun vinsn-insert-sm-operand (instruction value)
1862  )
1863
1864(defun vinsn-insert-dn-operand (instruction value)
1865  (set-field-value instruction (byte 4 16) value))
1866
1867(defun vinsn-insert-sn-operand (instruction value)
1868  )
1869   
1870
1871
1872
1873(provide "ARM-ASM")
Note: See TracBrowser for help on using the repository browser.