Changeset 13707


Ignore:
Timestamp:
May 18, 2010, 6:36:01 AM (15 years ago)
Author:
Gary Byers
Message:

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

Location:
branches/arm/compiler/ARM
Files:
1 added
4 edited

Legend:

Unmodified
Added
Removed

  • branches/arm/compiler/ARM/arm-arch.lisp

    r13705 r13707  
    2626
    2727
    28 (defvar *standard-arm-register-names* ())
    2928(defvar *arm-register-names* ())
    3029
    … …  
    5655                      "ARM register ~s currently has value ~d."
    5756                      name (cdr pair) value)
    58               (setf (cdr pair) value)))
    59           (push (cons string value) *arm-register-names*))
    60         value))))
     57              (setf (cdr pair) value))))
     58        (push (cons string value) *arm-register-names*))
     59        value)))
    6160
    6261(defmacro defarmgpr (name val)
    … …  
    106105(defarmgpr fname temp1)
    107106
    108 
    109 
     107(defarmgpr nargs imm2)
     108
     109
     110
     111
     112(defparameter *standard-arm-register-names* *arm-register-names*)
    110113
    111114
    … …  
    487490
    488491
    489 (defconstant canonical-nil-value (+ #x100000000 fulltag-nil))
     492(defconstant canonical-nil-value (+ #x10000000 fulltag-nil))
     493(defconstant nil-value canonical-nil-value)
     494
    490495;;; T is almost adjacent to NIL: since NIL is a misaligned CONS, it spans
    491496;;; two doublewords.  The arithmetic difference between T and NIL is
    … …  
    12701275(defconstant uuo-format-binary 15)      ;  4 bits of code, r1, r0
    12711276
     1277;;; xtypes: 8-bit integers used to report type errors for types that can't
     1278;;; be represented via tags.
     1279
     1280(defconstant xtype-unsigned-byte-24  252)
     1281(defconstant xtype-array2d  248)
     1282(defconstant xtype-array3d  244)
     1283(defconstant xtype-integer  4)
     1284(defconstant xtype-s64  8)
     1285(defconstant xtype-u64  12)
     1286(defconstant xtype-s32  16)
     1287(defconstant xtype-u32  20)
     1288(defconstant xtype-s16  24)
     1289(defconstant xtype-u16  28)
     1290(defconstant xtype-s8  32)
     1291(defconstant xtype-u8  36)
     1292(defconstant xtype-bit  40)                               
     1293
    12721294 
    12731295(provide "ARM-ARCH")

  • branches/arm/compiler/ARM/arm-asm.lisp

    r13705 r13707  
    2121(in-package "ARM")
    2222
    23 (defvar *arm-condition-names* (make-hash-table :test #'equalp))
    24 
    25 (dolist (pair '((eq . 0) (ne . 1)
    26                 (cc . 2) (hs . 2) (cs . 3) (lo .3)
    27                 (mi . 4) (pl . 5)
    28                 (vs . 6) (vc . 7)
    29                 (hi . 8) (ls . 9)
    30                 (ge . 10) (lt . 11)
    31                 (gt . 12) (le . 13)
    32                 (al . 14))) ; never say nv
    33   (setf (gethash (string (car pair)) *arm-condition-names*) (cdr pair)))
     23(defparameter *arm-condition-names* '(("eq" . 0) ("ne" . 1)
     24                                      ("cc" . 2) ("hs" . 2) ("cs" . 3) ("lo" . 3)
     25                                      ("mi" . 4) ("pl" . 5)
     26                                      ("vs" . 6) ("vc" . 7)
     27                                      ("hi" . 8) ("ls" . 9)
     28                                      ("ge" . 10) ("lt" . 11)
     29                                      ("gt" . 12) ("le" . 13)
     30                                      ("al" . 14)))
     31
     32
    3433
    3534(defun lookup-arm-condition-name (name)
    36   (values (gethash (string name) *arm-condition-names*)))
     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)))
    3739
    3840(defun need-arm-condition-name (name)
    … …  
    4244(defvar *arm-constants* ())
    4345(defvar *lap-labels* ())
     46(defvar *called-subprim-jmp-labels* ())
     47
     48
     49(defun arm-subprimitive-address (x)
     50  (if (and x (or (symbolp x) (stringp x)))
     51    (let* ((info (find x arm::*arm-subprims* :test #'string-equal :key #'ccl::subprimitive-info-name)))
     52      (when info
     53        (ccl::subprimitive-info-offset info)))))
     54
     55(defun arm-subprimitive-name (addr)
     56  (let* ((info (find addr arm::*arm-subprims* :key #'ccl::subprimitive-info-offset)))
     57    (when info
     58      (string (ccl::subprimitive-info-name info)))))
    4459
    4560
    … …  
    7388  ordinal                               ;if we need this
    7489  val
    75   mask                                  ;for disassembler
    7690  (flags 0)
    77   operand-types)
     91  operand-types
     92  mask-list)
    7893
    7994(eval-when (:compile-toplevel :load-toplevel :execute)
    … …  
    91106  rm
    92107  b
     108  subprim
     109  mem8
    93110)
    94111
    … …  
    105122    (:rm . ,arm-operand-type-rm)
    106123    (:b . ,arm-operand-type-b)
     124    (:subprim . ,arm-operand-type-subprim)
     125    (:mem8 . ,arm-operand-type-mem8)
    107126    ))
    108127
    … …  
    116135(ccl::defenum (:prefix "ARM-INSTRUCTION-FLAG-")
    117136  non-conditional                       ;doesn't use standard condition field
     137  prefer-separate-cond
    118138  )
    119139
    120140(defparameter *arm-instruction-flag-names*
    121141  `((:non-conditional . ,arm-instruction-flag-non-conditional)
     142    (:prefer-separate-cond . ,arm-instruction-flag-prefer-separate-cond)
    122143    ))
    123144
    … …  
    140161(defvar *arm-instruction-ordinals* (make-hash-table :test #'equalp))
    141162
    142 (defparameter *arm-instruction-stack* (make-array 100 :fill-pointer 0))
    143 
    144 
    145 (defun %define-arm-instruction (name value flags operand-types)
    146   (let* ((ordinal (length *arm-instruction-stack*)))
    147     (setf (gethash (string name) *arm-instruction-ordinals*)
    148           ordinal)
    149     (vector-push-extend
    150      (make-arm-instruction-template :name name
     163
     164
     165(defun %define-arm-instruction (name value mask-list flags operand-types)
     166  (make-arm-instruction-template :name name
    151167                                    :val value
    152                                     :ordinal ordinal
     168                                    :ordinal nil
     169                                    :mask-list mask-list
    153170                                    :flags (or flags 0)
    154                                     :operand-types operand-types)
    155         *arm-instruction-stack*)
    156   name))
    157 
    158 (defmacro define-arm-instruction (name value flag-names &rest operand-type-names)
    159   `(%define-arm-instruction ,(string-downcase name) ,value ,(%encode-arm-instruction-flag flag-names) ',(mapcar #'encode-arm-operand-type operand-type-names)))
    160 
    161 
    162 (define-arm-instruction and     #x0000000 () :rd :rn :shifter)
    163 (define-arm-instruction ands    #x0100000 () :rd :rn :shifter)
    164 (define-arm-instruction eor     #x0200000 () :rd :rn :shifter)
    165 (define-arm-instruction eors    #x0300000 () :rd :rn :shifter)
    166 (define-arm-instruction sub     #x0400000 () :rd :rn :shifter)
    167 (define-arm-instruction subs    #x0500000 () :rd :rn :shifter)
    168 (define-arm-instruction add     #x0800000 () :rd :rn :shifter)
    169 (define-arm-instruction adds    #x0900000 () :rd :rn :shifter)
    170 (define-arm-instruction adc     #x0a00000 () :rd :rn :shifter)
    171 (define-arm-instruction adcs    #x0b00000 () :rd :rn :shifter)
    172 (define-arm-instruction sbc     #x0c00000 () :rd :rn :shifter)
    173 (define-arm-instruction sbcs    #x0d00000 () :rd :rn :shifter)
    174 (define-arm-instruction orr     #x1800000 () :rd :rn :shifter)
    175 (define-arm-instruction orrs    #x1900000 () :rd :rn :shifter)
    176 (define-arm-instruction bic     #x1c00000 () :rd :rn :shifter)
    177 (define-arm-instruction bics    #x1d00000 () :rd :rn :shifter)
    178 (define-arm-instruction tst     #x1100000 () :rd :shifter)
    179 (define-arm-instruction tsts    #x1100000 () :rd :shifter)
    180 (define-arm-instruction cmp     #x1500000 () :rd :shifter)
    181 (define-arm-instruction cmps    #x1500000 () :rd :shifter)
    182 (define-arm-instruction cmn     #x1700000 () :rd :shifter)
    183 (define-arm-instruction cmns    #x1700000 () :rd :shifter)
    184 
    185 (define-arm-instruction mov     #x1a00000 () :rd :shifter)
    186 (define-arm-instruction movs    #x1b00000 () :rd :shifter)
    187 (define-arm-instruction mvn     #x1e00000 () :rd :shifter)
    188 (define-arm-instruction mvns    #x1f00000 () :rd :shifter)
    189 
    190 (define-arm-instruction ldr     #x4100000 () :rd :mem12)
    191 (define-arm-instruction ldrb    #x4500000 () :rd :mem12)
    192 (define-arm-instruction str     #x4000000 () :rd :mem12)
    193 (define-arm-instruction strb    #x4400000 () :rd :mem12)
    194 
    195 (define-arm-instruction stm     #x8800000 () :rnw :reglist)
    196 (define-arm-instruction stmia   #x8800000 () :rnw :reglist)
    197 (define-arm-instruction stmea   #x8800000 () :rnw :reglist)
    198 (define-arm-instruction ldm     #x8900000 () :rnw :reglist)
    199 (define-arm-instruction ldmia   #x8900000 () :rnw :reglist)
    200 (define-arm-instruction ldmfd   #x8900000 () :rnw :reglist)
    201 
    202 (define-arm-instruction b       #xa000000 () :b)
    203 (define-arm-instruction bl      #xb000000 () :b)
    204 (define-arm-instruction bx      #x12fff10 () :rm)
    205 (define-arm-instruction blx     #x12fff30 () :rm)
    206 
    207 ;;; UUOs
     171                                    :operand-types operand-types))
     172
     173(defmacro define-arm-instruction (name operand-type-names value mask-list flag-names)
     174  `(%define-arm-instruction ,(string-downcase name) ,value ',mask-list ,(%encode-arm-instruction-flag flag-names) ',(mapcar #'encode-arm-operand-type operand-type-names) ))
     175
     176(defparameter *arm-instruction-table*
     177  (vector
     178
     179;;; UUOs.
     180
    208181;;; Nullary UUOs
    209 (define-arm-instruction uuo-alloc-trap #x07f000f0 ())
    210 (define-arm-instruction uuo-error-wrong-nargs #x07f001f0 ())
    211 (define-arm-instruction uuo-gc-trap #x07f002f0 ())
    212 (define-arm-instruction uuo-debug-trap #x07f003f0 ())
    213 (define-arm-instruction uuo-interrupt-now #x07f004f0 ())
    214 (define-arm-instruction uuo-suspend-now #x07f005f0 ())
     182   (define-arm-instruction uuo-alloc-trap ()
     183     #x07f000f0
     184     #x0fffffff
     185     (:prefer-separate-cond))
     186   (define-arm-instruction uuo-error-wrong-nargs ()
     187     #x07f001f0
     188     #x0fffffff
     189     (:prefer-separate-cond))
     190   (define-arm-instruction uuo-gc-trap ()
     191     #x07f002f0
     192     #x0fffffff
     193     (:prefer-separate-cond))
     194   (define-arm-instruction uuo-debug-trap ()
     195     #x07f003f0
     196     #x0fffffff
     197     (:prefer-separate-cond))
     198   (define-arm-instruction uuo-interrupt-now ()
     199     #x07f004f0
     200     #x0fffffff
     201     (:prefer-separate-cond))
     202   (define-arm-instruction uuo-suspend-now ()
     203     #x07f005f0
     204     #x0fffffff
     205     (:prefer-separate-cond))
    215206
    216207;;; Misc format
    217 (define-arm-instruction uuo-error-reg-not-lisptag #x07f000f2 () :uuoA :uuo-unary)
    218 (define-arm-instruction uuo-error-reg-not-fulltag #x07f000f3 () :uuoA :uuo-unary)
    219 (define-arm-instruction uuo-error-reg-not-xtype   #x07f000f4 () :uuoA :uuo-unary)
    220 (define-arm-instruction uuo-cerror-reg-not-lisptag #x07f000fa () :uuoA :uuo-unary)
    221 (define-arm-instruction uuo-cerror-reg-not-fulltag #x07f000fb () :uuoA :uuo-unary)
    222 (define-arm-instruction uuo-cerror-reg-not-xtype   #x07f000fc () :uuoA :uuo-unary)
     208   (define-arm-instruction uuo-error-reg-not-lisptag (:uuoA :uuo-unary)
     209     #x07f000f2
     210     #x0ff000ff
     211     (:prefer-separate-cond))
     212   (define-arm-instruction uuo-error-reg-not-fulltag (:uuoA :uuo-unary)
     213     #x07f000f3
     214     #x0ff000ff
     215     (:prefer-separate-cond))
     216   (define-arm-instruction uuo-error-reg-not-xtype (:uuoA :uuo-unary)
     217     #x07f000f4
     218     #x0ff000ff
     219     (:prefer-separate-cond))
     220   (define-arm-instruction uuo-cerror-reg-not-lisptag (:uuoA :uuo-unary)
     221     #x07f000fa
     222     #x0ff000ff
     223     (:prefer-separate-cond))
     224   (define-arm-instruction uuo-cerror-reg-not-fulltag (:uuoA :uuo-unary)
     225     #x07f000fb
     226     #x0ff000ff
     227     (:prefer-separate-cond))
     228   (define-arm-instruction uuo-cerror-reg-not-xtype (:uuoA :uuo-unary)
     229     #x07f000fc
     230     #x0ff000ff
     231     (:prefer-separate-cond))
    223232
    224233;;; Unary UUOs
    225 (define-arm-instruction uuo-error-unbound          #x07f000f1 () :uuoA)
    226 (define-arm-instruction uuo-cerror-unbound         #x07f010f1 () :uuoA)
    227 (define-arm-instruction uuo-error-not-callable     #x07f020f1 () :uuoA)
    228 (define-arm-instruction uuo-tlb-too-small          #x07f030f1 () :uuoA)
    229 (define-arm-instruction uuo-error-no-throw-tag     #x07f040f1 () :uuoA)
     234   (define-arm-instruction uuo-error-unbound (:uuoA)
     235     #x07f000f1
     236     #x0ffff0ff
     237     (:prefer-separate-cond))
     238   (define-arm-instruction uuo-cerror-unbound (:uuoA)
     239     #x07f010f1
     240     #x0ffff0ff
     241     (:prefer-separate-cond))
     242   (define-arm-instruction uuo-error-not-callable (:uuoA)
     243     #x07f020f1
     244     #x0ffff0ff
     245     (:prefer-separate-cond))
     246   (define-arm-instruction uuo-tlb-too-small (:uuoA)
     247     #x07f030f1
     248     #x0ffff0ff
     249     (:prefer-separate-cond))
     250   (define-arm-instruction uuo-error-no-throw-tag (:uuoA)
     251     #x07f040f1
     252     #x0ffff0ff
     253     (:prefer-separate-cond))
    230254
    231255;;; Binary UUOs
    232 (define-arm-instruction uuo-error-vector-bounds    #x07f000ff () :uuoA :uuoB)
    233 (define-arm-instruction uuo-error-array-bounds     #x07f100ff () :uuoA :uuoB)
    234 
    235 
    236 (defparameter *arm-instruction-table* (copy-seq *arm-instruction-stack*))
     256   (define-arm-instruction uuo-error-vector-bounds (:uuoA :uuoB)
     257     #x07f000ff
     258     #x0fff00ff
     259     (:prefer-separate-cond))
     260   (define-arm-instruction uuo-error-array-bounds (:uuoA :uuoB)
     261     #x07f100ff
     262     #x0fff00ff
     263     (:prefer-separate-cond))
     264
     265
     266   (define-arm-instruction and (:rd :rn :shifter)
     267     #x00000000
     268     ((#x02000000 . #x0ff00000)
     269      (#x00000000 . #x0ff00010)
     270      (#x00000010 . #x0ff00090))
     271     ())
     272   (define-arm-instruction ands (:rd :rn :shifter)
     273     #x00100000
     274     ((#x03000000 . #x0ff00000)
     275      (#x01000000 . #x0ff00010)
     276      (#x01000010 . #x0ff00090))
     277     ())
     278   (define-arm-instruction eor (:rd :rn :shifter)
     279     #x00200000
     280     ((#x02200000 . #x0ff00000)
     281      (#x00200000 . #x0ff00010)
     282      (#x00200010 . #x0ff00090))
     283     ())
     284   (define-arm-instruction eors (:rd :rn :shifter)
     285     #x00300000
     286     ((#x02300000 . #x0ff00000)
     287      (#x00300000 . #x0ff00010)
     288      (#x00300010 . #x0ff00090))
     289     ())
     290   (define-arm-instruction sub (:rd :rn :shifter)
     291     #x00400000
     292     ((#x02400000 . #x0ff00000)
     293      (#x00400000 . #x0ff00010)
     294      (#x00400010 . #x0ff00090))
     295     ())
     296   (define-arm-instruction subs (:rd :rn :shifter)
     297     #x00500000
     298     ((#x02500000 . #x0ff00000)
     299      (#x00500000 . #x0ff00010)
     300      (#x00500010 . #x0ff00090))
     301     ())
     302   (define-arm-instruction rsb (:rd :rn :shifter)
     303     #x00600000
     304     ((#x02600000 . #x0ff00000)
     305      (#x00600000 . #x0ff00010)
     306      (#x00600010 . #x0ff00090))
     307     ())
     308   (define-arm-instruction rsbs (:rd :rn :shifter)
     309     #x00700000
     310     ((#x02700000 . #x0ff00000)
     311      (#x00700000 . #x0ff00010)
     312      (#x00700010 . #x0ff00090))
     313     ())   
     314   (define-arm-instruction add (:rd :rn :shifter)
     315     #x00800000
     316     ((#x02800000 . #x0ff00000)
     317      (#x00800000 . #x0ff00010)
     318      (#x00800010 . #x0ff00090))
     319     ())
     320   (define-arm-instruction adds (:rd :rn :shifter)
     321     #x00900000
     322     ((#x02900000 . #x0ff00000)
     323      (#x00900000 . #x0ff00010)
     324      (#x00900010 . #x0ff00090))
     325     ())
     326
     327   (define-arm-instruction adc (:rd :rn :shifter)
     328     #x00a00000
     329     ((#x02a00000 . #x0ff00000)
     330      (#x00a00000 . #x0ff00010)
     331      (#x00a00010 . #x0ff00090))
     332     ())
     333   (define-arm-instruction adcs (:rd :rn :shifter)
     334     #x00b00000
     335     ((#x02b00000 . #x0ff00000)
     336      (#x00b00000 . #x0ff00010)
     337      (#x00b00010 . #x0ff00090))
     338     ())
     339   (define-arm-instruction sbc (:rd :rn :shifter)
     340     #x00c00000
     341     ((#x02c00000 . #x0ff00000)
     342      (#x00c00000 . #x0ff00010)
     343      (#x00c00010 . #x0ff00090))
     344     ())
     345   (define-arm-instruction sbcs (:rd :rn :shifter)
     346     #x00d00000
     347     ((#x02d00000 . #x0ff00000)
     348      (#x00d00000 . #x0ff00010)
     349      (#x00d00010 . #x0ff00090))
     350     ())
     351   (define-arm-instruction rsc (:rd :rn :shifter)
     352     #x00e00000
     353     ((#x02e00000 . #x0ff00000)
     354      (#x00e00000 . #x0ff00010)
     355      (#x00e00010 . #x0ff00090))
     356     ())
     357   (define-arm-instruction rscs (:rd :rn :shifter)
     358     #x00e00000
     359     ((#x02e00000 . #x0ff00000)
     360      (#x00e00000 . #x0ff00010)
     361      (#x00e00010 . #x0ff00090))
     362     ())
     363   (define-arm-instruction tst (:rd :shifter)
     364     #x01100000
     365     ((#x03100000 . #x0ff00000)
     366      (#x01100000 . #x0ff00010)
     367      (#x01100010 . #x0ff00090))
     368     ())
     369   (define-arm-instruction tsts (:rd :shifter)
     370     #x01100000
     371     ((#x03100000 . #x0ff00000)
     372      (#x01100000 . #x0ff00010)
     373      (#x01100010 . #x0ff00090))
     374     ())
     375   (define-arm-instruction orr (:rd :rn :shifter)
     376     #x01800000
     377     ((#x03800000 . #x0ff00000)
     378      (#x01800000 . #x0ff00010)
     379      (#x01800010 . #x0ff00090))
     380     ())
     381   (define-arm-instruction orrs (:rd :rn :shifter)
     382     #x01900000
     383     ((#x03900000 . #x0ff00000)
     384      (#x01900000 . #x0ff00010)
     385      (#x01900010 . #x0ff00090))
     386     ())
     387   (define-arm-instruction bic (:rd :rn :shifter)
     388     #x01c00000
     389     ((#x03c00000 . #x0ff00000)
     390      (#x01c00000 . #x0ff00010)
     391      (#x01c00010 . #x0ff00090))
     392     ())
     393   (define-arm-instruction bics (:rd :rn :shifter)
     394     #x01d00000
     395     ((#x03d00000 . #x0ff00000)
     396      (#x01d00000 . #x0ff00010)
     397      (#x01d00010 . #x0ff00090))
     398     ())
     399   (define-arm-instruction cmp (:rd :shifter)
     400     #x01500000
     401     ((#x03500000 . #x0ff00000)
     402      (#x01500000 . #x0ff00010)
     403      (#x01500010 . #x0ff00090))
     404     ())
     405   (define-arm-instruction cmps (:rd :shifter)
     406     #x01500000
     407     ((#x03500000 . #x0ff00000)
     408      (#x01500000 . #x0ff00010)
     409      (#x01500010 . #x0ff00090))
     410     ())
     411   (define-arm-instruction cmn (:rd :shifter)
     412     #x01700000
     413     ((#x03700000 . #x0ff00000)
     414      (#x01700000 . #x0ff00010)
     415      (#x01700010 . #x0ff00090))
     416     ())
     417   (define-arm-instruction cmns (:rd :shifter)
     418     #x01700000
     419     ((#x03700000 . #x0ff00000)
     420      (#x01700000 . #x0ff00010)
     421      (#x01700010 . #x0ff00090))
     422     ())
     423
     424   ;; (ba subprim-name) -> (mov pc ($ subprim-address))
     425   (define-arm-instruction ba (:subprim)
     426     #x03a0f000
     427     #x0ffff000
     428     ())
     429   
     430   (define-arm-instruction mov (:rd :shifter)
     431     #x01a00000
     432     ((#x03a00000 . #x0ff00000)
     433      (#x01a00000 . #x0ff00010)
     434      (#x01a00010 . #x0ff00090))
     435     ())
     436   (define-arm-instruction movs (:rd :shifter)
     437     #x01b00000
     438     ((#x03b00000 . #x0ff00000)
     439      (#x01b00000 . #x0ff00010)
     440      (#x01b00010 . #x0ff00090))
     441     ())
     442   (define-arm-instruction mvn (:rd :shifter)
     443     #x01e00000
     444     ((#x03e00000 . #x0ff00000)
     445      (#x01e00000 . #x0ff00010)
     446      (#x01e00010 . #x0ff00090))
     447     ())
     448   (define-arm-instruction mvns (:rd :shifter)
     449     #x01f00000
     450     ((#x03f00000 . #x0ff00000)
     451      (#x01f00000 . #x0ff00010)
     452      (#x01f00010 . #x0ff00090))
     453     ())
     454
     455   (define-arm-instruction ldr (:rd :mem12)
     456     #x04100000
     457     #x0c500000
     458     ())
     459   (define-arm-instruction ldrb (:rd :mem12)
     460     #x04500000
     461     #x0c500000
     462     ())
     463   (define-arm-instruction str (:rd :mem12)
     464     #x04000000
     465     #x0c500000
     466     ())
     467   (define-arm-instruction strb (:rd :mem12)
     468     #x04400000
     469     #x0c500000
     470     ())
     471   (define-arm-instruction ldrh (:rd :mem8)
     472     #x001000b0
     473     #x0e3000f0
     474     ())
     475   (define-arm-instruction strh (:rd :mem8)
     476     #x000000b0
     477     #x0e3000f0
     478     ())
     479   (define-arm-instruction ldrsh (:rd :mem8)
     480     #x001000f0
     481     #x0e3000f0
     482     ())
     483   (define-arm-instruction ldrsb (:rd :mem8)
     484     #x001000d0
     485     #x0e3000f0
     486     ())
     487
     488   (define-arm-instruction stm (:rnw :reglist)
     489     #x08800000
     490     #x0ff00000
     491     ())
     492   (define-arm-instruction stmia (:rnw :reglist)
     493     #x08800000
     494     #x0ff00000
     495     ())
     496   (define-arm-instruction stmea (:rnw :reglist)
     497     #x08800000
     498     #x0ff00000
     499     ())
     500   (define-arm-instruction ldmia (:rnw :reglist)
     501     #x08900000
     502     #x0ff00000
     503     ())
     504   (define-arm-instruction ldm (:rnw :reglist)
     505     #x08900000
     506     #x0ff00000
     507     ())
     508   (define-arm-instruction ldmfd (:rnw :reglist)
     509     #x08900000
     510     #x0ff00000
     511     ())
     512   (define-arm-instruction stmdb (:rnw :reglist)
     513     #x09000000
     514     #x0ff00000
     515     ())
     516   (define-arm-instruction stmfb (:rnw :reglist)
     517     #x09000000
     518     #x0ff00000
     519     ())
     520   (define-arm-instruction stmfd (:rnw :reglist)
     521     #x09000000
     522     #x0ff00000
     523     ())
     524   (define-arm-instruction ldmdb (:rnw :reglist)
     525     #x09100000
     526     #x0ff00000
     527     ())
     528   (define-arm-instruction ldmea (:rnw :reglist)
     529     #x09100000
     530     #x0ff00000
     531     ())
     532
     533   (define-arm-instruction b (:b)
     534     #x0a000000
     535     #x0e000000
     536     ())
     537   (define-arm-instruction bl (:b)
     538     #x0b000000
     539     #x0e000000
     540     ())
     541   (define-arm-instruction bx (:rm)
     542     #x012fff10
     543     #x0ffffff0
     544     ())
     545   (define-arm-instruction blx (:rm)
     546     #x012fff30
     547     #x0ffffff0
     548     ())
     549   ))
     550
     551(dotimes (i (length *arm-instruction-table*))
     552  (let* ((template (svref *arm-instruction-table* i))
     553         (name (arm-instruction-template-name template)))
     554    (setf (arm-instruction-template-ordinal template) i
     555          (gethash name *arm-instruction-ordinals*) i)))
     556
     557   
     558
     559
    237560
    238561(defun lookup-arm-instruction (name)
    … …  
    287610                            (ash  u32 (- r)))))))
    288611
    289 ;;; Return a 12-bit value encodeing u32 as an 8-bit constant rotated
     612;;; Return a 12-bit value encoding u32 as an 8-bit constant rotated
    290613;;; by an even number of bits if u32 can be encoded that way, nil
    291614;;; otherwise.
    … …  
    295618       ((= rot 32) (values nil nil))
    296619    (let* ((a (arm-rotate-left u32 rot)))
    297       (if (<= a #xff)
     620      (when (<= a #xff)
    298621        (return (logior (ash rot 7) a))))))
    299622
    … …  
    301624(eval-when (:execute :load-toplevel)
    302625  (defstruct (instruction-element (:include ccl::dll-node))
    303     address)
     626    address
     627    (size 0))
    304628
    305629;;; A LAP-INSTRUCTION's field-values list contains (byte-spec . value)
    … …  
    316640;;; be applied at vinsn-definition time.
    317641 
    318   (defstruct (lap-instruction (:include instruction-element)
    319                                    (:constructor %make-lap-instruction (source)))
     642  (defstruct (lap-instruction (:include instruction-element (size 4))
     643                              (:constructor %make-lap-instruction (source)))
    320644    source                              ; for LAP, maybe vinsn-template
    321645    (opcode 0)
    322     field-values
     646    vinsn-info                          ;tbd
    323647    )
    324648
    325   (defstruct (lap-note (:include instruction-element))
    326     peer
    327     id)
    328 
    329   (defstruct (lap-note-begin (:include lap-note)))
    330   (defstruct (lap-note-end (:include lap-note)))
    331649   
    332650  (defstruct (lap-label (:include instruction-element)
    … …  
    339657
    340658
    341 (defun make-field-value (size position value)
    342   (cons (byte size position) value))
    343 
    344 (defun add-field-value (instruction size position value)
    345   (push (make-field-value size position value)
    346         (lap-instruction-field-values instruction)))
    347 
    348 (defun set-field-value (instruction size position value)
     659(eval-when (:compile-toplevel :execute)
     660  (declaim (inline set-field-value)))
     661
     662(defun set-field-value (instruction bytespec value)
    349663  (setf (lap-instruction-opcode instruction)
    350         (dpb value (byte size position) (lap-instruction-opcode instruction))))
     664        (dpb value bytespec (lap-instruction-opcode instruction))))
    351665
    352666
    … …  
    416730          ))
    417731
    418 (defconstant arm-pseudofield-shifter-constant 0)
    419732
    420733   
    421734(defun parse-rd-operand (form instruction)
    422   (set-field-value instruction 4 12 (need-arm-gpr form)))
     735  (set-field-value instruction (byte 4 12) (need-arm-gpr form)))
    423736
    424737(defun parse-rn-operand (form instruction)
    425   (set-field-value instruction 4 16 (need-arm-gpr form)))
     738  (set-field-value instruction (byte 4 16) (need-arm-gpr form)))
    426739
    427740(defun parse-shifter-operand (form instruction)
    428741  (if (atom form)
    429742    ;; rm is shorthand for (:lsl rm (:$ 0)); the :lsl is encoded as 0.
    430     (set-field-value instruction 12 0 (need-arm-gpr form))
     743    (set-field-value instruction (byte 12 0) (need-arm-gpr form))
    431744    (if (ccl::quoted-form-p form)
    432       (add-field-value instruction 0 arm-pseudofield-shifter-constant
    433                        (need-constant form))
     745      (insert-shifter-constant (need-constant form) instruction)
    434746      (let* ((op (keywordize (car form))))
    435747        (ecase op
    436748          (:$ (destructuring-bind (value) (cdr form)
    437                 (add-field-value instruction 0 arm-pseudofield-shifter-constant
    438                                  (eval value))))
     749                (insert-shifter-constant (eval value) instruction)))
    439750          (:rrx (destructuring-bind (reg) (cdr form)
    440                   (set-field-value instruction 12 0
     751                  (set-field-value instruction (byte 12 0)
    441752                                   (logior (need-arm-gpr reg)
    442753                                           (ash (encode-arm-shift-type :ror) 5)))))
    … …  
    444755           (destructuring-bind (reg count) (cdr form)
    445756             (if (atom count)
    446                (set-field-value instruction 12 0
     757               (set-field-value instruction (byte 12 0)
    447758                                (logior (need-arm-gpr reg)
    448759                                        (ash 1 4)
    … …  
    451762               (ecase (keywordize (car count))
    452763                 (:$ (destructuring-bind (countval) (cdr count)
    453                        (set-field-value instruction 12 0
     764                       (set-field-value instruction (byte 12 0)
    454765                                        (logior (need-arm-gpr reg)
    455766                                                (ash (encode-arm-shift-type op) 5)
    456                                                 (ash (logand 31 (eval countval)) 8))))))))))))))
     767                                                (ash (logand 31 (eval countval)) 7))))))))))))))
    457768     
    458 (defun insert-shifter-constant (value opcode)
    459   (let* ((constant (encode-arm-immediate value)))
    460     (if constant
    461       (logior constant (logior (ash 1 25) opcode))
    462       ;; If value couldn't be encoded but its complement can be
    463       ;; and there's an instruction that can operate on complemented
    464       ;; values, change the instruction and encode the complemented
    465       ;; value.  If that doesn't work, try negating the value and
    466       ;; seeing if there's an equivalent instruction that could use
    467       ;; that.  If none of this works, complain that the value can't
    468       ;; be encoded.
    469       (let* ((op (ldb (byte 4 21) opcode))
    470              (newop nil))
    471         (if (or (and (setq constant (encode-arm-immediate (lognot value)))
    472                      (setq newop (svref op *equivalent-complemented-opcodes*)))
    473                 (and (setq constant (encode-arm-immediate (- value)))
    474                      (setq newop (svref op *equivalent-negated-opcodes*))))
    475           (logior constant
    476                   (logior (ash 1 25) (dpb newop (byte 4 21) opcode)))
    477           (error "Can't encode ARM constant ~s." value))))))
     769(defun insert-shifter-constant (value instruction)
     770  (let* ((opcode (lap-instruction-opcode instruction))
     771         (constant (encode-arm-immediate value)))
     772    (setf (lap-instruction-opcode instruction)
     773          (if constant
     774            (logior constant (logior (ash 1 25) opcode))
     775            ;; If value couldn't be encoded but its complement can be
     776            ;; and there's an instruction that can operate on complemented
     777            ;; values, change the instruction and encode the complemented
     778            ;; value.  If that doesn't work, try negating the value and
     779            ;; seeing if there's an equivalent instruction that could use
     780            ;; that.  If none of this works, complain that the value can't
     781            ;; be encoded.
     782            (let* ((op (ldb (byte 4 21) opcode))
     783                   (newop nil))
     784              (if (or (and (setq constant (encode-arm-immediate (lognot value)))
     785                           (setq newop (svref *equivalent-complemented-opcodes* op)))
     786                      (and (setq constant (encode-arm-immediate (- value)))
     787                           (setq newop (svref *equivalent-negated-opcodes* op))))
     788                (logior constant
     789                        (logior (ash 1 25) (dpb newop (byte 4 21) opcode)))
     790                (error "Can't encode ARM constant ~s." value)))))))
     791
     792(defun set-addressing-mode (instruction mode constant-index)
     793  ;; Look at mode and set P/W/U bits.  If CONSTANT-INDEX is
     794  ;; true, the U bit depends on the sign of the constant.
     795  (ecase mode           
     796    ((:@ :+@ :+@! :@!)
     797     ;; Preindexed, no writeback unless :+@! , add register operands.
     798     (unless constant-index
     799       (set-field-value instruction (byte 1 23) 1))
     800     (when (eq mode :+@!)
     801       (set-field-value instruction (byte 1 21) 1))
     802     (set-field-value instruction (byte 1 24) 1))
     803    ((:-@ :-@!)
     804     ;; Preindexed. Leave the U bit clear, maybe set W if writeback.
     805     (when (eq mode :-@!)
     806       (set-field-value instruction (byte 1 21) 1))
     807     (set-field-value instruction (byte 1 24) 1))
     808    ((:@+ :@-)
     809     ;; Postindex; writeback is implicit (and setting P and W would
     810     ;; change the instruction.)
     811     (unless (or (eq mode :@-) constant-index)
     812       (set-field-value instruction (byte 1 23) 1)))))
    478813
    479814;;; "general" address operand, as used in LDR/LDRB/STR/STRB
    480 (defun parse-memory-operand (form instruction)
     815(defun parse-m12-operand (form instruction)
    481816  (if (atom form)
    482817    (error "Invalid memory operand ~s" form)   
    483818    (let* ((mode (keywordize (car form))))
    484       (destructuring-bind (rn &optional (index '(:$ 0) index-p)) (cdr form)
    485         (unless (or index-p (eq mode :@))
    486           (error "missing index in memory operand ~s." form))
    487         (set-field-value instruction 4 16 (need-arm-gpr rn))
    488         (let* ((quoted (ccl::quoted-form-p form))
    489                (index-op (if quoted :quote (and (consp index) (keywordize (car index)))))
    490                (constant-index (or quoted (eq index-op :$))))
    491           (cond (constant-index
    492                  (destructuring-bind (val) (cdr index)
    493                    (let* ((constval (if quoted
    494                                       (need-constant index)
    495                                       (eval val))))
    496                      (if (< constval 0)
    497                        (setq constval (- constval))
    498                        ;; das u bit
    499                        (set-field-value instruction 1 23 1))
    500                      (unless (typep constval '(unsigned-byte 12))
    501                        (warn "constant offset too large : ~s" constval))
    502                      (set-field-value instruction 12 0 constval))))
    503                 (t
    504                  (set-field-value instruction 1 25 1)
    505                  (if (atom index)
    506                    (set-field-value instruction 12 0 (need-arm-gpr index))
    507                    ;; Shifts here are always by a constant (not another reg)
    508                    (if (eq index-op :rrx)
    509                      (destructuring-bind (rm) (cdr index)
    510                        (set-field-value instruction 12 0
    511                                         (logior (need-arm-gpr rm)
    512                                                 (ash (encode-arm-shift-type :ror) 5))))
     819      (if (eq mode :=)
     820        (destructuring-bind (label) (cdr form)
     821          (when (arm::arm-subprimitive-address label)
     822            (error "Invalid label in ~s." form))
     823          (set-field-value instruction (byte 4 16) arm::pc)
     824          (set-field-value instruction (byte 1 24) 1) ;P bit
     825          ;; Insert function will have to set U bit appropriately.
     826          (lap-note-label-reference label instruction :mem12))
     827        (destructuring-bind (rn &optional (index '(:$ 0) index-p)) (cdr form)
     828          (unless (or index-p (eq mode :@))
     829            (error "missing index in memory operand ~s." form))
     830          (set-field-value instruction (byte 4 16) (need-arm-gpr rn))
     831          (let* ((quoted (ccl::quoted-form-p index))
     832                 (index-op (if quoted :quote (and (consp index) (keywordize (car index)))))
     833                 (constant-index (or quoted (eq index-op :$))))
     834            (cond (constant-index
     835                   (destructuring-bind (val) (cdr index)
     836                     (let* ((constval (if quoted
     837                                        (need-constant index)
     838                                        (eval val))))
     839                       (if (< constval 0)
     840                         (setq constval (- constval))
     841                         ;; das u bit
     842                         (set-field-value instruction (byte 1 23) 1))
     843                       (unless (typep constval '(unsigned-byte 12))
     844                         (warn "constant offset too large : ~s" constval))
     845                       (set-field-value instruction (byte 12 0) constval))))
     846                  (t
     847                   (set-field-value instruction (byte 1 25) 1)
     848                   (if (atom index)
     849                     (set-field-value instruction (byte 12 0) (need-arm-gpr index))
     850                     ;; Shifts here are always by a constant (not another reg)
     851                     (if (eq index-op :rrx)
     852                       (destructuring-bind (rm) (cdr index)
     853                         (set-field-value instruction (byte 12 0)
     854                                          (logior (need-arm-gpr rm)
     855                                                  (ash (encode-arm-shift-type :ror) 5))))
    513856                     
    514                      (destructuring-bind (rm shift-expr) (cdr index)
    515                        (unless (and (consp shift-expr)
    516                                     (eq (keywordize (car shift-expr)) :$))
    517                          (error "Shift count must be immediate : ~s" shift-expr))
    518                        (destructuring-bind (count-expr) (cdr shift-expr)
    519                          (set-field-value instruction 12 0
    520                                           (logior (need-arm-gpr rm)
    521                                                   (ash (encode-arm-shift-type
    522                                                         index-op) 5)
    523                                                   (ash (logand 31 (eval count-expr))
    524                                                        7)))))))))
    525           ;; Now, look at mode and set P/W/U bits.  If CONSTANT-INDEX is
    526           ;; true, the U bit depends on the sign of the constant.
    527           (ecase mode           
    528             ((:@ :+@ :+@!)
    529              ;; Preindexed, no writeback unless :+@! , add register operands.
    530              (unless constant-index
    531                (set-field-value instruction 1 23 1))
    532              (when (eq mode :+@!)
    533                (set-field-value instruction 1 21 1))
    534              (set-field-value instruction 1 24 1))
    535             ((:-@ :-@!)
    536              ;; Preindexed. Leave the U bit clear, maybe set W if writeback.
    537              (when (eq mode :-@!)
    538                (set-field-value instruction 1 21 1))
    539              (set-field-value instruction 1 24 1))
    540             ((:@+ :@-)
    541              ;; Postindex; writeback is implicit (and setting P and W would
    542              ;; change the instruction.)
    543              (unless (or (eq mode :@-) constant-index)
    544                (set-field-value instruction 1 23 1)))))))))
     857                       (destructuring-bind (rm shift-expr) (cdr index)
     858                         (unless (and (consp shift-expr)
     859                                      (eq (keywordize (car shift-expr)) :$))
     860                           (error "Shift count must be immediate : ~s" shift-expr))
     861                         (destructuring-bind (count-expr) (cdr shift-expr)
     862                           (set-field-value instruction (byte 12 0)
     863                                            (logior (need-arm-gpr rm)
     864                                                    (ash (encode-arm-shift-type
     865                                                          index-op) 5)
     866                                                    (ash (logand 31 (eval count-expr))
     867                                                         7)))))))))
     868            (set-addressing-mode instruction mode constant-index)))))))
    545869
    546870(defun parse-reglist-operand (form instruction)
    … …  
    553877    (if (zerop mask)
    554878      (error "Empty register list ~s." form)
    555       (set-field-value instruction 16 0 mask))))
     879      (set-field-value instruction (byte 16 0) mask))))
    556880
    557881(defun parse-rnw-operand (form instruction)
    558882  (if (atom form)
    559     (set-field-value instruction 4 16 (need-arm-gpr form))
     883    (set-field-value instruction (byte 4 16) (need-arm-gpr form))
    560884    (if (eq (keywordize (car form)) :!)
    561885      (destructuring-bind (rn) (cdr form)
    562         (set-field-value instruction 1 21 1)
    563         (set-field-value instruction 4 16 (need-arm-gpr rn)))
     886        (set-field-value instruction (byte 1 21) 1)
     887        (set-field-value instruction (byte 4 16) (need-arm-gpr rn)))
    564888      (error "Unrecognize writeback indicator in ~s." form))))
    565889
    566890(defun parse-uuoA-operand (form instruction)
    567   (set-field-value instruction 4 8 (need-arm-gpr form)))
     891  (set-field-value instruction (byte 4 8) (need-arm-gpr form)))
    568892
    569893(defun parse-uuo-unary-operand (form instruction)
    570   (set-field-value instruction 4 12 (need-constant form)))
     894  (set-field-value instruction (byte 8 12) (need-constant form)))
    571895
    572896(defun parse-uuoB-operand (form instruction)
    573   (set-field-value instruction 4 12 (need-arm-gpr form)))
     897  (set-field-value instruction (byte 4 12) (need-arm-gpr form)))
    574898
    575899(defun parse-rm-operand (form instruction)
    576   (set-field-value instruction 4 0 (need-arm-gpr form)))
     900  (set-field-value instruction (byte 4 0) (need-arm-gpr form)))
    577901
    578902(defun parse-b-operand (form instruction)
    579   (lap-note-label-reference form instruction :b))
    580 
    581 
    582 
    583 
     903  (let* ((address (arm-subprimitive-address form)))
     904    (if address
     905      (let* ((lab (or (find-lap-label form)
     906                      (make-lap-label form))))
     907        (pushnew lab *called-subprim-jmp-labels*)
     908        (push (cons instruction :b) (lap-label-refs lab)))
     909      (lap-note-label-reference form instruction :b))))
     910
     911(defun parse-subprim-operand (form instruction)
     912  (let* ((address (arm-subprimitive-address form)))
     913    (unless address
     914      (error "Unknown ARM subprimitive : ~s" form))
     915    (set-field-value instruction (byte 12 0) (encode-arm-immediate address))))
     916   
     917(defun parse-m8-operand (form instruction)
     918  (if (atom form)
     919    (error "Invalid memory operand ~s." form)
     920    (let* ((mode (keywordize (car form)))
     921           (constant-index nil))
     922      (destructuring-bind (rn index) (cdr form)
     923        (set-field-value instruction (byte 4 16) (need-arm-gpr rn))
     924        (cond ((atom index)
     925               (set-field-value instruction (byte 4 0) (need-arm-gpr index))
     926               (set-field-value instruction (byte 25 1) 1))
     927              (t (unless (eq (keywordize (car index)) :$)
     928                   (error "Invalid index: ~s." index))
     929                 (destructuring-bind (val) (cdr index)
     930                   (let* ((value (eval val)))
     931                     (setq constant-index t)
     932                     (if (< value 0)
     933                       (setq value (- value))
     934                       (set-field-value instruction (byte 23 1) 1))
     935                     (set-field-value instruction (byte 4 0) (ldb (byte 4 0) value))
     936                     (set-field-value instruction (byte 4 8) (ldb (byte 4 4) value)))))))
     937    (set-addressing-mode instruction mode constant-index))))
     938       
     939                             
     940         
    584941
    585942(defparameter *arm-operand-parsers*
    … …  
    587944      parse-rn-operand
    588945      parse-shifter-operand
    589       parse-memory-operand
     946      parse-m12-operand
    590947      parse-reglist-operand
    591948      parse-rnw-operand
    … …  
    595952      parse-rm-operand
    596953      parse-b-operand
     954      parse-subprim-operand
     955      parse-m8-operand
    597956      ))
    598957
    599 ;;; FORM is a list; its car isn't a pseudo-op or lapmacro; try to generate
    600 ;;; an instruction.
    601 (defun assemble-instruction (form)
    602   (let* ((insn (%make-lap-instruction form)))
     958
     959
     960(defun make-lap-instruction (form)
     961  (let* ((insn (ccl::alloc-dll-node *lap-instruction-freelist*)))
     962    (if (typep insn 'lap-instruction)
     963      (progn
     964        (setf (lap-instruction-source insn) form
     965              (lap-instruction-address insn) nil
     966              (lap-instruction-vinsn-info insn) nil
     967              (lap-instruction-opcode insn) nil)
     968        insn)
     969      (%make-lap-instruction form))))
     970
     971;;; FORM is a list and its car isn't a pseudo-op or lapmacro; try to
     972;;; generate an instruction.
     973(defun assemble-instruction (seg form)
     974  (let* ((insn (make-lap-instruction form)))
    603975    (destructuring-bind (name . opvals) form
    604976      (multiple-value-bind (template cond explicit-cond) (lookup-arm-instruction name)
    … …  
    614986                  (error "Can't use explicit condition and :? : ~s" condform)
    615987                  (setq cond c))))))
    616              
    617988        (let* ((optypes (arm-instruction-template-operand-types template))
    618989               (n (length optypes)))
    … …  
    628999            (setf (lap-instruction-opcode insn)
    6291000                  (dpb cond (byte 4 28) (lap-instruction-opcode insn))))
    630           insn)))))
     1001          (ccl::append-dll-node insn seg))))))
    6311002
    6321003;;; A label can only be emitted once.  Once it's been emitted, its pred/succ
    … …  
    6691040    lab))
    6701041
     1042(defun emit-lap-label (seg name)
     1043  (let* ((lab (find-lap-label name)))
     1044    (if  lab
     1045      (when (lap-label-emitted-p lab)
     1046        (error "Label ~s: multiply defined." name))
     1047      (setq lab (make-lap-label name)))
     1048    (ccl::append-dll-node lab seg)))
     1049
     1050(defmacro do-lap-labels ((lab &optional result) &body body)
     1051  (let* ((thunk-name (gensym))
     1052         (k (gensym))
     1053         (xlab (gensym)))
     1054    `(flet ((,thunk-name (,lab) ,@body))
     1055      (if (listp *lap-labels*)
     1056        (dolist (,xlab *lap-labels*)
     1057          (,thunk-name ,xlab))
     1058        (maphash #'(lambda (,k ,xlab)
     1059                     (declare (ignore ,k))
     1060                     (,thunk-name ,xlab))
     1061                 *lap-labels*))
     1062      ,result)))
     1063
     1064(defun set-element-addresses (start seg)
     1065  (ccl::do-dll-nodes (element seg start)
     1066    (setf (instruction-element-address element) start)
     1067    (incf start (instruction-element-size element))))
     1068
     1069(defun count-element-sizes (seg)
     1070  (let* ((start 0))
     1071    (ccl::do-dll-nodes (element seg start)
     1072    (incf start (instruction-element-size element)))))
     1073
     1074(defun arm-finalize (primary constant-pool)
     1075  (dolist (lab *called-subprim-jmp-labels*)
     1076    (unless (lap-label-emitted-p lab)
     1077      (ccl::append-dll-node lab primary)
     1078      (assemble-instruction primary `(ba ,(lap-label-name lab)))))
     1079  (let* ((constants-size (count-element-sizes constant-pool)))
     1080    (unless (eql constants-size 0)
     1081      (let* ((c0 (make-lap-instruction nil)))
     1082        (setf (lap-instruction-opcode c0) (ash constants-size -2))
     1083        (ccl::insert-dll-node-before c0 (ccl::dll-header-first constant-pool)))))
     1084  (let* ((w0 (make-lap-instruction nil))
     1085         (w1 (make-lap-instruction nil)))
     1086    (setf (lap-instruction-opcode w0) 0)
     1087    (ccl::append-dll-node w0 primary)
     1088    (ccl::append-dll-node w1 primary )
     1089    (let* ((n (set-element-addresses 0 primary)))
     1090      (setf (lap-instruction-opcode w1) n)
     1091      (set-element-addresses n constant-pool)))
     1092  ;; Now fix up label references.  Recall that the PC value at some
     1093  ;; point in program execution is 8 bytes beyond that point.
     1094  (do-lap-labels (lab)
     1095    (if (lap-label-emitted-p lab)
     1096      (let* ((labaddr (lap-label-address lab)))
     1097        (dolist (ref (lap-label-refs lab))
     1098          (destructuring-bind (insn . reftype) ref
     1099            (let* ((diff-in-bytes (- labaddr (+ 8 (lap-instruction-address insn)))))
     1100              (case reftype
     1101                (:b (setf (lap-instruction-opcode insn)
     1102                          (dpb (ash diff-in-bytes -2)
     1103                               (byte 24 0)
     1104                               (lap-instruction-opcode insn))))
     1105                (:mem12
     1106                 (if (>= diff-in-bytes 0)
     1107                   (set-field-value insn (byte 1 23) 1)
     1108                   (setq diff-in-bytes (- diff-in-bytes)))
     1109                 (set-field-value insn (byte 12 0) diff-in-bytes))
     1110                (t
     1111                 (error "Label type ~s invalid or not yet supported."
     1112                        reftype)))))))
     1113      (if (lap-label-refs lab)
     1114        (error "LAP label ~s was referenced but not defined." (lap-label-name lab)))))
     1115  (ccl::merge-dll-nodes primary constant-pool)
     1116  (let* ((last (ccl::dll-header-last primary)))
     1117    (ash (+ (instruction-element-address last)
     1118            (instruction-element-size last)) -2)))
     1119     
     1120
    6711121(provide "ARM-ASM")

  • branches/arm/compiler/ARM/arm-lap.lisp

    r13705 r13707  
    4141     ',name))
    4242
    43 (defvar *arm-lap-constants* ())
    44 (defvar *arm-lap-regsave-reg* ())
    45 (defvar *arm-lap-regsave-addr* ())
    46 (defvar *arm-lap-regsave-label* ())
    4743(defvar *arm-lap-lfun-bits* 0)
    4844
    4945
    50 (defmacro do-lap-labels ((lab &optional result) &body body)
    51   (let* ((thunk-name (gensym))
    52          (k (gensym))
    53          (xlab (gensym)))
    54     `(flet ((,thunk-name (,lab) ,@body))
    55       (if (listp arm::*lap-labels*)
    56         (dolist (,xlab arm::*lap-labels*)
    57           (,thunk-name ,xlab))
    58         (maphash #'(lambda (,k ,xlab)
    59                      (declare (ignore ,k))
    60                      (,thunk-name ,xlab))
    61                  arm::*lap-labels*))
    62       ,result)))
     46
    6347
    6448
    … …  
    7761
    7862(defun %define-arm-lap-function (name body &optional (bits 0))
    79   (with-dll-node-freelist (*lap-instructions* arm::*lap-instruction-freelist*)
    80       (let* ((*lap-labels* ())
     63  (with-dll-node-freelist (primary arm::*lap-instruction-freelist*)
     64    (with-dll-node-freelist (constant-pool arm::*lap-instruction-freelist*)
     65      (let* ((arm::*lap-labels* ())
    8166             (arm::*arm-constants* ())
    82              (*arm-lap-lfun-bits* bits))
     67             (*arm-lap-lfun-bits* bits)
     68             (arm::*arm-register-names* arm::*standard-arm-register-names*)
     69             (arm::*called-subprim-jmp-labels* ())
     70             (current primary)
     71             (sections (vector primary constant-pool)))
     72        (declare (dynamic-extent sections))
    8373        (dolist (form body)
    84           (arm-lap-form form))
    85         (arm-lap-generate-code name (arm-lap-do-labels) *arm-lap-lfun-bits*))))
    86 
    87 
    88 
    89 (defun arm-lap-assign-addresses (delete-labels-p)
    90   (let* ((pc 0))
    91     (declare (fixnum pc))
    92     (do-dll-nodes (node *lap-instructions*)
    93       (setf (arm::instruction-element-address node) pc)
    94       (if (typep node 'arm::lap-label)
    95         (if delete-labels-p (remove-dll-node node))
    96         (incf pc 4)))
    97     ;; Don't bother checking code-vector size yet.
    98     pc))
    99 
    100 
    101 
    102 (defun arm-lap-do-labels ()
    103   (do-lap-labels (lab)
    104     (if (and (arm::lap-label-refs lab) (not (arm::lap-label-emitted-p lab)))
    105       (error "Label ~S was referenced but never defined. "
    106              (arm::lap-label-name lab)))
    107     ;; Repeatedly iterate through label's refs, until none of them is
    108     ;; the preceding instruction.  This eliminates
    109     ;; (b @next)
    110     ;;@next
    111     ;;
    112     ;; but can probably be fooled by hairier nonsense.
    113     (loop
    114       (when (dolist (ref (arm::lap-label-refs lab) t)
    115               (when (eq lab (arm::lap-instruction-succ ref))
    116                 (remove-dll-node ref)
    117                 (setf (arm::lap-label-refs lab) (delete ref (arm::lap-label-refs lab)))
    118                 (return)))
    119         (return))))
    120   ;; Assign pc to emitted labels, splice them out of the list.
    121  
    122     (arm-lap-assign-addresses t))
    123 
    124 ;;; Replace each label with the difference between the label's address
    125 ;;; and the referencing instruction's address.
    126 (defun arm-lap-resolve-labels ()
    127   (do-lap-labels (label)
    128     (let* ((label-address (arm::lap-label-address label)))
    129       (declare (fixnum label-address))          ; had BETTER be ...
    130       (dolist (insn (arm::lap-label-refs label))
    131         (let* ((diff (- label-address (arm::lap-instruction-address insn))))
    132           (declare (fixnum diff))
    133           (let* ((opvals (arm::lap-instruction-parsed-operands insn))
    134                  (pos (position label opvals)))
    135             (unless pos
    136               (error "Bug: label ~s should be referenced by instruction ~s, but isn't." label insn))
    137             (setf (svref opvals pos) diff)))))))
    138 
    139 (defun arm-lap-generate-instruction (code-vector index insn)
    140   (let* ((op (arm::lap-instruction-opcode insn))
    141          (vals (lap-instruction-parsed-operands insn))
    142          (high (opcode-op-high op))
    143          (low (opcode-op-low op))
    144          (idx -1))
    145     (dolist (operand (opcode-operands op))
    146       (let* ((val (if (logbitp operand-fake (operand-flags operand))
    147                     0
    148                     (svref vals (incf idx))))
    149              (insert-function (operand-insert-function operand)))
    150         (multiple-value-setq (high low)
    151           (if insert-function
    152             (funcall insert-function high low val)
    153             (arm::insert-default operand high low val)))
    154         (if (null high)
    155           (error "Invalid operand for ~s instruction: ~d" (opcode-name op) val))))
    156     (setf (lap-instruction-parsed-operands insn) nil)
    157     (free-lap-operand-vector vals)
    158     (locally (declare (type (simple-array (unsigned-byte 16) (*)) code-vector)
    159                       (optimize (speed 3) (safety 0)))
    160       (setf (aref code-vector (+ index index)) high
    161             (aref code-vector (+ index index 1)) low)
    162      nil)))
    163 
    164 
    165 
    166 (defun arm-lap-generate-code (name maxpc bits)
    167   (declare (fixnum maxpc))
     74          (setq current (arm-lap-form form current sections)))
     75        (arm-lap-generate-code name
     76                               primary
     77                               (arm::arm-finalize primary  constant-pool)
     78                               *arm-lap-lfun-bits*)))))
     79
     80
     81
     82
     83
     84
     85
     86(defun arm-lap-generate-code (name seg code-vector-size bits)
     87  (declare (fixnum code-vector-size))
    16888  (let* ((target-backend *target-backend*)
    169          (cross-compiling (not (eq *host-backend* target-backend)))
    170 
    171          (prefix (arch::target-code-vector-prefix (backend-target-arch *target-backend*)))
    172          (prefix-size (length prefix))
    173          (code-vector-size (+ (ash maxpc -2) prefix-size))
    174 
    175          (constants-size (+ 4 (length *arm-lap-constants*)))
     89         (cross-compiling (target-arch-case
     90                           (:arm (not (eq *host-backend* target-backend)))
     91                           (t t)))
     92         (constants-size (+ 4 (length arm::*arm-constants*)))
    17693         (constants-vector (%alloc-misc
    17794                            constants-size
    … …  
    17996                              target::subtag-xfunction
    18097                              target::subtag-function)))
    181          (i prefix-size))
     98         (i 0))
    18299    (declare (fixnum i constants-size))
    183100    (let* ((code-vector (%alloc-misc
    … …  
    186103                           target::subtag-xcode-vector
    187104                           arm::subtag-code-vector))))
    188       (dotimes (j prefix-size)
    189         (setf (uvref code-vector j) (pop prefix)))
    190       (arm-lap-resolve-labels)          ; all operands fully evaluated now.
    191       (do-dll-nodes (insn *lap-instructions*)
    192         (arm-lap-generate-instruction code-vector i insn)
    193         (incf i))
    194 
    195       (dolist (immpair *arm-lap-constants*)
     105      (do-dll-nodes (insn seg)
     106        (unless (eql (arm::instruction-element-size insn) 0)
     107          (setf (uvref code-vector i) (arm::lap-instruction-opcode insn))
     108          (incf i)))
     109      (dolist (immpair arm::*arm-constants*)
    196110        (let* ((imm (car immpair))
    197111               (k (cdr immpair)))
    198112          (declare (fixnum k))
    199           (setf (uvref constants-vector
    200                        (ash
    201                         (- k (arch::target-misc-data-offset (backend-target-arch target-backend)))
    202                         (- (arch::target-word-shift (backend-target-arch target-backend)))))
    203                 imm)))
     113          (setf (uvref constants-vector (+ 2 k)) imm)))
    204114      (setf (uvref constants-vector (1- constants-size)) bits ; lfun-bits
    205115            (uvref constants-vector (- constants-size 2)) name
    206             (uvref constants-vector 0) code-vector)
     116            (uvref constants-vector 1) code-vector)
    207117      #+arm-target (%make-code-executable code-vector)
    208118      constants-vector)))
    209119
    210 (defun arm-lap-pseudo-op (form)
    211   (case (car form)
    212     (:arglist (setq *arm-lap-lfun-bits* (encode-lambda-list (cadr form))))))
    213 
     120(defun arm-lap-pseudo-op (directive arg current sections)
     121  (flet ((check-usage (directive)
     122           (unless (eq current (svref sections 1))
     123             (error "~s directive should only be used inside :data section" directive))))
     124    (ecase directive
     125      (:arglist (setq *arm-lap-lfun-bits* (encode-lambda-list arg)))
     126      (:data
     127       (setq current (svref sections 1)))
     128      (:text
     129       (setq current (svref sections 0)))
     130      (:section
     131       (setq current (svref sections
     132                            (ecase arg
     133                              (:text 0)
     134                              (:data 1)))))
     135      (:word
     136       (check-usage :word)
     137       (append-dll-node
     138        (let* ((insn (arm::make-lap-instruction nil)))
     139          (setf (arm::lap-instruction-opcode insn) (logand #xffffffff (eval arg)))
     140          insn)
     141        current))
     142     
     143      (:single
     144       (check-usage :single)
     145       (append-dll-node
     146        (let* ((insn (arm::make-lap-instruction nil)))
     147          (setf (arm::lap-instruction-opcode insn) (single-float-bits (float (eval arg) 0.0f0)))
     148          insn)
     149        current))
     150      (:double
     151       (check-usage :double)
     152       (multiple-value-bind (high low) (double-float-bits (float (eval arg) 0.0d0))
     153         (let* ((insnlow (arm::make-lap-instruction nil))
     154                (insnhigh (arm::make-lap-instruction nil)))
     155           (setf (arm::lap-instruction-opcode insnlow) low
     156                 (arm::lap-instruction-opcode insnhigh) high)
     157           (append-dll-node insnlow current)
     158           (append-dll-node insnhigh current)))))
     159    current))
    214160       
    215 (defun arm-lap-form (form)
     161
     162       
     163(defun arm-lap-form (form current sections)
    216164  (if (and form (symbolp form))
    217     (emit-lap-label form)
     165    (arm::emit-lap-label current form)
    218166    (if (or (atom form) (not (symbolp (car form))))
    219167      (error "~& unknown ARM-LAP form: ~S ." form)
    … …  
    221169                           (arm-lap-macroexpand-1 form)
    222170        (if expanded
    223           (arm-lap-form expansion)
     171          (setq current (arm-lap-form expansion current sections))
    224172          (let* ((name (car form)))
    225173            (if (keywordp name)
    226               (arm-lap-pseudo-op form)
     174              (setq current (arm-lap-pseudo-op name (cadr form) current sections))
    227175              (case name
    228                 ((progn) (dolist (f (cdr form)) (arm-lap-form f)))
    229                 ((let) (arm-lap-equate-form (cadr form) (cddr form)))
     176                ((progn) (dolist (f (cdr form)) (setq current (arm-lap-form f current sections))))
     177                ((let) (setq current (arm-lap-equate-form (cadr form) (cddr form) current sections)))
    230178                (t
    231                  (arm-lap-instruction name (cdr form)))))))))))
     179                 (arm::assemble-instruction current form)))))))))
     180  current)
    232181
    233182;;; (let ((name val) ...) &body body)
    234183;;; each "val" gets a chance to be treated as a ARM register name
    235184;;; before being evaluated.
    236 (defun arm-lap-equate-form (eqlist body)
     185(defun arm-lap-equate-form (eqlist body current sections)
    237186  (collect ((symbols)
    238187            (values))
    … …  
    245194                       (not (arm::get-arm-register symbol)))
    246195            (error "~s is not a bindable symbol name . " symbol))
    247           (let* ((regval (arm::get-arm-register value)))
     196          (let* ((regval (and value
     197                              (or (typep value 'symbol)
     198                                  (typep value 'string))
     199                              (arm::get-arm-register value))))
    248200            (if regval
    249201              (arm::define-arm-register symbol regval)
    … …  
    253205
    254206    (progv (symbols) (values)
    255       (dolist (form body)
    256         (arm-lap-form form))))))
    257 
    258 (defun arm-lap-constant-offset (x)
    259   (or (cdr (assoc x *arm-lap-constants* :test #'equal))
    260       (let* ((target-backend *target-backend*)
    261              (n (+ (arch::target-misc-data-offset (backend-target-arch target-backend))
    262                    (ash (1+ (length *arm-lap-constants*))
    263                         (arch::target-word-shift (backend-target-arch target-backend))))))
    264         (push (cons x n) *arm-lap-constants*)
    265         n)))
    266 
    267 ; Evaluate an arbitrary expression; warn if the result isn't a fixnum.
    268 (defun arm-lap-evaluated-expression (x)
    269   (if (typep x 'fixnum)
    270     x
    271     (if (null x)
    272       (arch::target-nil-value (backend-target-arch *target-backend*))
    273       (if (eq x t)
    274         (+ (arch::target-nil-value (backend-target-arch *target-backend*))
    275            (arch::target-t-offset  (backend-target-arch *target-backend*)))
    276         (let* ((val (handler-case (eval x) ; Look! Expression evaluation!
    277                       (error (condition) (error "~&Evaluation of ~S signalled assembly-time error ~& ~A ."
    278                                                 x condition)))))
    279           (unless (typep val 'fixnum)
    280             (warn "assembly-time evaluation of ~S returned ~S, which may not have been intended ."
    281                   x val))
    282           val)))))
    283 
    284 (defparameter *arm-lap-register-aliases*
    285   `((nfn . ,arm::nfn)
    286     (fname . ,arm::fname)))
    287 
    288 (defparameter *arm-lap-fp-register-aliases*
    289   ())
    290 
    291 (defparameter *arm-lap-vector-register-aliases*
    292   ())
    293 
    294 (defun arm-gpr-name-p (x)
    295   (and (or (symbolp x) (stringp x))
    296            (or
    297             (position (string x) arm::*gpr-register-names* :test #'string-equal)
    298             (cdr (assoc x *arm-lap-register-aliases* :test #'string-equal)))))
    299 
    300 (defun arm-register-name-or-expression (x)
    301   (if x
    302     (or (arm-gpr-name-p x)
    303         (if (and (consp x) (eq (car x) 'quote))
    304           (let* ((quoted-form (cadr x)))
    305             (if (null quoted-form)
    306               (arch::target-nil-value (backend-target-arch *target-backend*))
    307               (if (eq quoted-form t)
    308                 (+ (arch::target-nil-value (backend-target-arch *target-backend*))
    309                    (arch::target-t-offset (backend-target-arch *target-backend*)))
    310                 (if (typep quoted-form 'fixnum)
    311                   (ash quoted-form (arch::target-fixnum-shift (backend-target-arch *target-backend*)))
    312                   (arm-lap-constant-offset quoted-form)))))
    313           (arm-lap-evaluated-expression x)))
    314     (arch::target-nil-value (backend-target-arch *target-backend*))))
    315 
    316 (defun arm-fpr-name-p (x)
    317   (and (or (symbolp x) (stringp x))
    318                    (or
    319                     (position (string x) arm::*fpr-register-names* :test #'string-equal)
    320                     (cdr (assoc x *arm-lap-fp-register-aliases* :test #'string-equal)))))
    321 
    322 (defun arm-fp-register-name-or-expression (x)
    323   (or (arm-fpr-name-p x)
    324       (arm-lap-evaluated-expression x)))
    325 
    326 (defun arm-vr-name-p (x)
    327   (and (or (symbolp x) (stringp x))
    328              (or
    329               (position (string x) arm::*vector-register-names* :test #'string-equal)
    330               (cdr (assoc x *arm-lap-vector-register-aliases* :test #'string-equal)))))
    331 
    332 (defun arm-vector-register-name-or-expression (x)
    333   (or (arm-vr-name-p x)
    334       (arm-lap-evaluated-expression x)))
    335 
    336 
    337 (defparameter *arm-cr-field-names* #(:crf0 :crf1 :crf2 :crf3 :crf4 :crf5 :crf6 :crf7))
    338 (defparameter *arm-cr-names* #(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7))
    339 (defparameter *arm-cc-bit-names* #(:lt :gt :eq :so :un))
    340 (defparameter *arm-cc-bit-inverse-names* #(:ge :le :ne :ns :nu))
    341 
    342 ; This wants a :CC, a negated :CC, or either (:CRn :CC) or (:CRn :~CC).
    343 ; Returns the fully-qualified CR bit and an indication of whether or not the CC was
    344 ; negated.
    345 (defun arm-lap-parse-test (x)
    346   (if (or (symbolp x) (stringp x))
    347     (let* ((pos (position x *arm-cc-bit-names* :test #'string-equal)))
    348       (if pos
    349         (values (min pos 3) nil)
    350         (if (setq pos (position x *arm-cc-bit-inverse-names* :test #'string-equal))
    351           (values (min pos 3) t)
    352           (error "Unknown ARM lap condition form : ~s" x))))
    353     (if (and (consp x) (keywordp (car x)) (consp (cdr x)) (keywordp (cadr x)))
    354       (let* ((field (position (car x) *arm-cr-names*)))
    355         (unless field (error "Unknown CR field name : ~s" (car x)))
    356         (let* ((bit (position (cadr x) *arm-cc-bit-names*)))
    357           (if bit
    358             (values (logior (ash field 2) (min bit 3)) nil)
    359             (if (setq bit (position (cadr x) *arm-cc-bit-inverse-names*))
    360               (values (logior (ash field 2) (min bit 3)) t)
    361               (error "Unknown condition name : ~s" (cadr x))))))
    362       (error "Unknown ARM lap condition form : ~s" x))))
    363 
    364 ; Accept either :CRn, :CC,  or (:CRFn :CC), or evaluate an expression.
    365 (defun arm-lap-cr-field-expression (x)
    366   (if (or (symbolp x) (stringp x))
    367     (let* ((pos (position x *arm-cr-names* :test #'string-equal)))
    368       (if pos
    369         (ash pos 2)
    370         (let* ((cc-pos (position x *arm-cc-bit-names* :test #'string-equal)))
    371           (if cc-pos
    372             (min cc-pos 3)
    373             (arm-lap-evaluated-expression x)))))
    374     (if (and (consp x) (keywordp (car x)) (consp (cdr x)) (keywordp (cadr x)))
    375       (let* ((field (position (car x) *arm-cr-field-names*))
    376              (bit (position (cadr x) *arm-cc-bit-names*)))
    377         (if (and field bit)
    378           (logior (min bit 3) (ash field 2))
    379           (error "Bad arm-cr-field-expression: ~s" x)))
    380       (arm-lap-evaluated-expression x))))
    381  
    382 (defun arm-lap-instruction (name opvals)
    383   (let* ((opnum (gethash (string name) arm::*arm-opcode-numbers*))
    384          (opcode (and opnum
    385                           (< -1 opnum (length arm::*arm-opcodes*))
    386                           (svref arm::*arm-opcodes* opnum))))
    387     (unless opcode
    388           (error "Unknown ARM opcode: ~a" name))
    389     ;; Unless either
    390     ;;  a) The number of operand values in the macro call exactly
    391     ;;      matches the number of operands accepted by the instruction or
    392     ;;  b) The number of operand values is one less, and the instuction
    393     ;;     takes an optional operand
    394     ;;  we've got a wrong-number-of-args error.
    395     ;;  In case (b), there's at most one optional argument per instruction;
    396     ;;   provide 0 for the missing value.
    397     (let* ((operands (opcode-operands opcode))
    398            (nmin (opcode-min-args opcode))
    399            (nmax (opcode-max-args opcode))
    400            (nhave (length opvals)))
    401       (declare (fixnum nmin nmax nhave))
    402       (if (= nhave nmax)
    403         (arm-emit-lap-instruction opcode opvals)
    404         (if (> nhave nmax)
    405           (error "Too many operands in ~s (~a accepts at most ~d)"
    406                  opvals name nmax)
    407           (if (= nhave nmin)
    408             (let* ((newops ()))
    409               (dolist (op operands (arm-emit-lap-instruction opcode (nreverse newops)))
    410                 (let* ((flags (operand-flags op)))
    411                   (unless (logbitp operand-fake flags)
    412                     (push (if (logbitp operand-optional flags)
    413                             0
    414                             (pop opvals))
    415                           newops)))))
    416             (error "Too few operands in ~s : (~a requires at least ~d)"
    417                    opvals name nmin)))))))
    418 
    419 ; This is pretty rudimentary: if the operand has the "arm::$arm-operand-relative" bit
    420 ; set, we demand a label name and note the fact that we reference the label in question.
    421 ; Otherwise, we use the "register-name-or-expression" thing.
    422 ; Like most ARM assemblers, this lets you treat everything as an expression, even if
    423 ; you've got the order of some arguments wrong ...
    424 
    425 (defun arm-parse-lap-operand (opvalx operand insn)
    426   (let* ((flags (operand-flags operand)))
    427     (declare (fixnum flags))
    428     (if (logbitp arm::$arm-operand-relative flags)
    429       (lap-note-label-reference opvalx insn)
    430       (if (logbitp arm::$arm-operand-cr flags)
    431         (arm-lap-cr-field-expression opvalx)
    432         (if (logbitp arm::$arm-operand-absolute flags)
    433           (arm-subprimitive-address opvalx)
    434           (if (logbitp arm::$arm-operand-fpr flags)
    435             (arm-fp-register-name-or-expression opvalx)
    436             (if (logbitp arm::$arm-operand-vr flags) ; SVS
    437               (arm-vector-register-name-or-expression opvalx)
    438               (arm-register-name-or-expression opvalx))))))))
    439 
    440 (defun arm-subprimitive-address (x)
    441   (if (and x (or (symbolp x) (stringp x)))
    442     (let* ((info (find x arm::*arm-subprims* :test #'string-equal :key #'subprimitive-info-name)))
    443       (when info (return-from arm-subprimitive-address
    444                    (subprimitive-info-offset info)))))
    445   (arm-lap-evaluated-expression x))
    446 
    447 
    448 ;;; We've checked that the number of operand values match the number
    449 ;;; expected (and have set "fake" operand values to 0.)  Labels - and
    450 ;;; some constructs that might someday do arithmetic on them - are
    451 ;;; about the only class of forward references we need to deal with.
    452 ;;; This whole two-pass scheme seems overly general, but if/when we
    453 ;;; ever do instruction scheduling it'll probably make it simpler.
    454 (defun arm-emit-lap-instruction (opcode opvals)
    455   (let* ((operands (opcode-operands opcode))
    456          (parsed-values (alloc-lap-operand-vector))
    457          (insn (make-lap-instruction opcode))
    458          (idx -1))
    459     (declare (fixnum idx))
    460     (dolist (op operands)
    461       (let* ((flags (operand-flags op))
    462              (val (if (logbitp operand-fake flags)
    463                     0
    464                     (arm-parse-lap-operand (pop opvals) op insn))))
    465         (declare (fixnum flags))
    466         (setf (svref parsed-values (incf idx)) val)))
    467     (setf (lap-instruction-parsed-operands insn) parsed-values)
    468     (append-dll-node insn *lap-instructions*)))
     207      (dolist (form body current)
     208        (setq current (arm-lap-form form current sections)))))))
     209
     210
     211
     212
     213
    469214
    470215

  • branches/arm/compiler/ARM/arm-lapmacros.lisp

    r13705 r13707  
    4444          (uuo-error-wrong-nargs (:? lo))
    4545          (cmp nargs ($ (ash ,max arm::fixnumshift)))
    46           (uuo-error-wrong-nargs (:? hi)))))))
     46          (uuo-error-wrong-nargs (:? hi)))))))
    4747
    4848
    … …  
    7878
    7979(defarmlapmacro pop1 (dest stack)
    80   `(ldr ,dest (:@+ ,stack (:% arm::node-size))))
     80  `(ldr ,dest (:@+ ,stack (:$ arm::node-size))))
    8181
    8282(defarmlapmacro vpop1 (dest)
    83   `(pop ,dest vsp))
     83  `(pop1 ,dest vsp))
    8484
    8585(defarmlapmacro %cdr (dest node)
    … …  
    107107    (ldrbeq ,dest (:@ ,node (:$ arm::misc-subtag-offset)))))
    108108
     109;;; Set the EQ bit if NODE is a fixnum
     110(defarmlapmacro test-fixnum (node)
     111  `(tst ,node (:$ arm::tagmask)))
     112
    109113(defarmlapmacro trap-unless-fixnum (node)
    110114  `(progn
    111     (tst node (:$ arm::tagmask))
    112     (uuo-error-reg-not-lisptag (:? ne) node (:$ arm::tag-fixnum))))
    113 
    114 
    115 (defarmlapmacro trap-unless-lisptag= (node tag &optional (immreg imm0))
     115    (test-fixnum ,node)
     116    (uuo-error-reg-not-lisptag (:? ne) ,node (:$ arm::tag-fixnum))))
     117
     118
     119(defarmlapmacro trap-unless-lisptag= (node tag &optional (immreg 'imm0))
    116120  `(progn
    117121    (extract-lisptag ,immreg ,node)
    … …  
    119123    (uuo-error-reg-not-lisptag (:? ne) ,node (:$ ,tag))))
    120124
    121 (defarmlapmacro trap-unless-fulltag= (node tag &optional (immreg imm0))
     125(defarmlapmacro trap-unless-fulltag= (node tag &optional (immreg 'imm0))
    122126  `(progn
    123127    (extract-fulltag ,immreg ,node)
    … …  
    126130
    127131
    128 (defarmlapmacro trap-unless-xtype= (node tag &optional (immreg imm0))
     132(defarmlapmacro trap-unless-xtype= (node tag &optional (immreg 'imm0))
    129133  `(progn
    130134    (extract-typecode ,immreg ,node)
    … …  
    138142;;; This is about as hard on the pipeline as anything I can think of.
    139143(defarmlapmacro call-symbol (function-name)
    140   (load-constant fname ,function-name)
    141   (ldr nfn (:@ fname (:$ arm::symbol.fname)))
    142   (ldr lr (:@ nfn (:$ arm::function.entrypoint)))
    143   (blx lr))
     144  `(progn
     145    (load-constant fname ,function-name)
     146    (ldr nfn (:@ fname (:$ arm::symbol.fname)))
     147    (ldr lr (:@ nfn (:$ arm::function.entrypoint)))
     148    (blx lr)))
    144149
    145150(defarmlapmacro sp-call-symbol (function-name)
    … …  
    159164(defarmlapmacro header-length (dest vheader)
    160165  `(progn
    161     (mov ,dest (:$ (- arm::fixnumone)))
    162     (and ,dest ,dest (:lsr ,src (:$ (- arm::num-subtag-bits arm::fixnumshift))))))
     166    (mov ,dest '-1)
     167    (and ,dest ,dest (:lsr ,vheader (:$ (- arm::num-subtag-bits arm::fixnumshift))))))
    163168
    164169
    … …  
    186191(defarmlapmacro vref32 (dest miscobj index scaled-idx)
    187192  `(progn
    188     (add ,scaled-idex ,index (:$ arm::misc-data-offset))
     193    (add ,scaled-idx ,index (:$ arm::misc-data-offset))
    189194    (ldr ,dest (:@ ,miscobj ,scaled-idx))))
    190195
    … …  
    192197(defarmlapmacro vset32 (src miscobj index scaled-idx)
    193198  `(progn
    194     (add ,scaled-idex ,index (:$ arm::misc-data-offset))
     199    (add ,scaled-idx ,index (:$ arm::misc-data-offset))
    195200    (str ,src (:@ ,miscobj ,scaled-idx))))
    196201
    … …  
    210215  `(progn
    211216    ,@(if check
    212           ((trap-unless-xtype= ,src arm::subtag-character ,dest)))
    213     (mov ,dest ,src (:lsr arm::charcode-shift))))
     217          `((trap-unless-xtype= ,src arm::subtag-character ,dest)))
     218    (mov ,dest ,src (:lsr (:$ arm::charcode-shift)))))
    214219
    215220
    … …  
    256261  `(progn
    257262    (fmrs ,temp ,src)
    258     (str ,temp (:@ ,node (:$ arm::single-float.value))))
     263    (str ,temp (:@ ,node (:$ arm::single-float.value)))))
    259264
    260265(defarmlapmacro put-double-float (src node)
    … …  
    292297  `(ldr ,dest (:@ ,macptr (:$ arm::macptr.address))))
    293298
    294 (defarmlapmacro svref (dest index vector))
     299(defarmlapmacro svref (dest index vector)
    295300 `(ldr ,dest (:@ ,vector (:$ (+ (* 4 ,index) arm::misc-data-offset)))))
    296301
    … …  
    301306
    302307(defarmlapmacro vpush-argregs ()
    303   (let* ((none (gensym))
    304          (two (gensym))
    305          (one (gensym)))
     308  (let* ((none (gensym)))
    306309  `(progn
    307310    (cmp nargs (:$ 0))
Note: See TracChangeset for help on using the changeset viewer.