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

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

UUO-ERROR-FPU-EXCEPTION.
Parse FPUX operands (fpscr, etc.) in vinsns.

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