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

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

Some stuff compiles; still a lot of work to do.
Try to reduce stack traffic in some simple cases by tracking which
registers contain copies of which stack locations. Should try to
exploit this further (and port to other platforms when it's working
reliably.)
Todo: well, a very long list of things, but one that seems obvious
is to try to use predication (at the vinsn level) to reduce the number
of conditional branches.

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