Changeset 14042 for branches


Ignore:
Timestamp:
Jul 25, 2010, 8:59:17 PM (9 years ago)
Author:
gb
Message:

Split ARM instructions into two 16-bit halves, to try to reduce
incidental consing in the assembler.

Location:
branches/arm/compiler/ARM
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • branches/arm/compiler/ARM/arm-asm.lisp

    r14033 r14042  
    895895                              (:constructor %make-lap-instruction (source)))
    896896    source                              ; for LAP, maybe vinsn-template
    897     (opcode 0)
    898     vinsn-info                          ;tbd
     897    (opcode-high 0)
     898    (opcode-low 0)
    899899    )
    900900
     
    909909
    910910
    911 (eval-when (:compile-toplevel :execute)
    912   (declaim (inline set-field-value)))
     911(defun set-opcode-values (high low bytespec value)
     912  (declare (type (unsigned-byte 16) low high))
     913  (let* ((width (byte-size bytespec))
     914         (pos (byte-position bytespec)))
     915    (declare (type (unsigned-byte 5) width pos))
     916    (cond ((<= (the fixnum (+ width pos)) 16)
     917           (values high (dpb value bytespec low)))
     918          ((>= pos 16)
     919           (values (dpb value (byte width (- pos 16)) high) low))
     920          ;; Branch displacements are about the only things
     921          ;; that span the two halves of an instruction.
     922          (t
     923           (let* ((low-width (- 16 pos))
     924                  (high-width (- width low-width)))
     925             (declare (fixnum low-width high-width))
     926             (values (dpb (ldb (byte high-width low-width) value)
     927                          (byte high-width 0)
     928                          high)
     929                     (dpb (ldb (byte low-width 0) value)
     930                        (byte low-width pos)
     931                        low)))))))
    913932
    914933(defun set-field-value (instruction bytespec value)
    915   (setf (lap-instruction-opcode instruction)
    916         (dpb value bytespec (lap-instruction-opcode instruction))))
     934  (let* ((low (lap-instruction-opcode-low instruction))
     935         (high (lap-instruction-opcode-high instruction)))
     936    (declare (type (unsigned-byte 16) low high))
     937    (multiple-value-bind (new-high new-low)
     938        (set-opcode-values high low bytespec value)
     939      (declare (type (unsigned-byte 16) new-low new-high))
     940      (unless (eql low new-low)
     941        (setf (lap-instruction-opcode-low instruction) new-low))
     942      (unless (eql high new-high)
     943        (setf (lap-instruction-opcode-high instruction) new-high)))))
     944
     945
     946(defun get-opcode-field (high low bytespec)
     947  (declare (fixnum high low))
     948  (let* ((width (byte-size bytespec))
     949         (pos (byte-position bytespec)))
     950    (declare (fixnum width pos))
     951    (cond ((<= (the fixnum (+ width pos)) 16)
     952           (ldb bytespec low))
     953          ((>= pos 16)
     954           (ldb (byte width (- pos 16)) high))
     955          ;; Branch displacements are about the only things
     956          ;; that span the two halves of an instruction.
     957          (t
     958           (let* ((low-width (- 16 pos))
     959                  (high-width (- width low-width)))
     960             (declare (fixnum low-width high-width))
     961             (dpb (ldb (byte high-width 0) high)
     962                  (byte high-width low-width)
     963                  (ldb (byte low-width pos) low)))))))
     964 
     965(defun get-field-value (instruction bytespec)
     966  (get-opcode-field (lap-instruction-opcode-high instruction)
     967                    (lap-instruction-opcode-low instruction)
     968                    bytespec))
    917969
    918970
     
    10301082     
    10311083(defun insert-shifter-constant (value instruction)
    1032   (let* ((opcode (lap-instruction-opcode instruction))
    1033          (constant (encode-arm-immediate value)))
    1034     (setf (lap-instruction-opcode instruction)
    1035           (if constant
    1036             (logior constant (logior (ash 1 25) opcode))
    1037             ;; If value couldn't be encoded but its complement can be
    1038             ;; and there's an instruction that can operate on complemented
    1039             ;; values, change the instruction and encode the complemented
    1040             ;; value.  If that doesn't work, try negating the value and
    1041             ;; seeing if there's an equivalent instruction that could use
    1042             ;; that.  If none of this works, complain that the value can't
    1043             ;; be encoded.
    1044             (let* ((op (ldb (byte 4 21) opcode))
    1045                    (newop nil))
    1046               (if (or (and (setq constant (encode-arm-immediate (lognot value)))
    1047                            (setq newop (svref *equivalent-complemented-opcodes* op)))
    1048                       (and (setq constant (encode-arm-immediate (- value)))
    1049                            (setq newop (svref *equivalent-negated-opcodes* op))))
    1050                 (logior constant
    1051                         (logior (ash 1 25) (dpb newop (byte 4 21) opcode)))
    1052                 (error "Can't encode ARM constant ~s." value)))))))
    1053 
    1054 (defun set-opcode-value-from-addressing-mode (opcode mode constant-index)
     1084  (let* ((constant (encode-arm-immediate value)))
     1085    (cond (constant
     1086            (set-field-value instruction (byte 12 0) constant)
     1087            (set-field-value instruction (byte 1 25) 1))
     1088          (t
     1089           ;; If value couldn't be encoded but its complement can be
     1090           ;; and there's an instruction that can operate on complemented
     1091           ;; values, change the instruction and encode the complemented
     1092           ;; value.  If that doesn't work, try negating the value and
     1093           ;; seeing if there's an equivalent instruction that could use
     1094           ;; that.  If none of this works, complain that the value can't
     1095           ;; be encoded.
     1096           (let* ((op (get-field-value instruction (byte 4 21)))
     1097                  (newop nil))
     1098             (if (or (and (setq constant (encode-arm-immediate (lognot value)))
     1099                          (setq newop (svref *equivalent-complemented-opcodes* op)))
     1100                     (and (setq constant (encode-arm-immediate (- value)))
     1101                          (setq newop (svref *equivalent-negated-opcodes* op))))
     1102               (progn
     1103                 (set-field-value instruction (byte 1 25) 1)
     1104                 (set-field-value instruction (byte 12 0) constant)
     1105                 (set-field-value instruction (byte 4 21) newop))
     1106               (error "Can't encode ARM constant ~s." value)))))))
     1107
     1108(defun set-opcode-value-from-addressing-mode (high mode constant-index)
    10551109  ;; Look at mode and set P/W/U bits.  If CONSTANT-INDEX is
    10561110  ;; true, the U bit depends on the sign of the constant.
     
    10591113     ;; Preindexed, no writeback unless :[+]@! , add register operands.
    10601114     (unless constant-index
    1061        (setq opcode (logior opcode (ash 1 23))))
     1115       (setq high (logior high (ash 1 (- 23 16)))))
    10621116     (when (or (eq mode :+@!)
    10631117               (eq mode :@!))
    1064        (setq opcode (logior opcode (ash 1 21))))
    1065      (setq opcode (logior opcode (ash 1 24))))
     1118       (setq high (logior high (ash 1 (- 21 16)))))
     1119     (setq high (logior high (ash 1 (- 24 16)))))
    10661120    ((:-@ :-@!)
    10671121     ;; Preindexed. Leave the U bit clear, maybe set W if writeback.
    10681122     (when (eq mode :-@!)
    1069        (setq opcode (logior opcode (ash 1 21))))
    1070      (setq opcode (logior opcode (ash 1 24))))
     1123       (setq high (logior high (ash 1 (- 21 16)))))
     1124     (setq high (logior high (ash 1 (- 24 16)))))
    10711125    ((:@+ :@-)
    10721126     ;; Postindex; writeback is implicit (and setting P and W would
    10731127     ;; change the instruction.)
    10741128     (unless (or (eq mode :@-) constant-index)
    1075        (setq opcode (logior opcode (ash 1 23))))))
    1076   opcode)
     1129       (setq high (logior high (ash 1 (- 23 16)))))))
     1130  high)
    10771131
    10781132
    10791133(defun set-addressing-mode (instruction mode constant-index)
    1080   (setf (lap-instruction-opcode instruction)
     1134  (setf (lap-instruction-opcode-high instruction)
    10811135        (set-opcode-value-from-addressing-mode
    1082          (lap-instruction-opcode instruction) mode constant-index)))
     1136         (lap-instruction-opcode-high instruction)
     1137         mode
     1138         constant-index)))
     1139
    10831140
    10841141;;; "general" address operand, as used in LDR/LDRB/STR/STRB
     
    13261383        (setf (lap-instruction-source insn) form
    13271384              (lap-instruction-address insn) nil
    1328               (lap-instruction-vinsn-info insn) nil
    1329               (lap-instruction-opcode insn) nil)
     1385              (lap-instruction-opcode-low insn) 0
     1386              (lap-instruction-opcode-high insn) 0)
    13301387        insn)
    13311388      (%make-lap-instruction form))))
     
    13681425          (unless (= n (length opvals))
    13691426            (error "ARM ~a instructions require ~d operands, but ~d were provided in ~s." (arm-instruction-template-name template) n (length opvals) form))
    1370           (setf (lap-instruction-opcode insn)
    1371                 (arm-instruction-template-val template))
     1427          (set-field-value insn (byte 32 0) (arm-instruction-template-val template))
    13721428          (dotimes (i n)
    13731429            (let* ((optype (pop optypes))
     
    13751431              (funcall (svref *arm-operand-parsers* optype) val insn)))
    13761432          (when cond
    1377             (setf (lap-instruction-opcode insn)
    1378                   (dpb cond (byte 4 28) (lap-instruction-opcode insn))))
     1433            (set-field-value insn (byte 4 28) cond))
    13791434          (emit-lap-instruction-element insn seg))))))
    13801435
     
    14731528               (offset-label (make-lap-label (gensym))))
    14741529          (assemble-instruction primary `(b ,target-name))
    1475           (setf (lap-instruction-opcode origin) 0)
     1530          (set-field-value origin (byte 32 0) 0)
    14761531          (emit-lap-instruction-element origin primary)
    14771532          (setq *last-constant-pool-origin* origin)
    1478           (setf (lap-instruction-opcode offset) 0)
     1533          (set-field-value offset (byte 32 0) 0)
    14791534          (emit-lap-instruction-element offset primary)
    1480           (setf (lap-instruction-opcode pool-count)
    1481                 (ash n-constant-bytes (- arm::word-shift)))
     1535          (set-field-value pool-count (byte 32 0) (ash n-constant-bytes (- arm::word-shift)))
    14821536          (emit-lap-instruction-element pool-count primary)
    14831537          (ccl::do-dll-nodes (datum constant-pool)
     
    15081562    (unless (eql constants-size 0)
    15091563      (let* ((c0 (make-lap-instruction nil)))
    1510         (setf (lap-instruction-opcode c0) (ash constants-size -2))
     1564        (set-field-value c0 (byte 32 0) (ash constants-size -2))
    15111565        (ccl::insert-dll-node-before c0 (ccl::dll-header-first constant-pool)))))
    15121566  (let* ((w0 (make-lap-instruction nil))
    15131567         (w1 (make-lap-instruction nil)))
    1514     (setf (lap-instruction-opcode w0) 0)
     1568    (set-field-value w0 (byte 32 0) 0)
    15151569    (ccl::append-dll-node w0 primary)
    15161570    (ccl::append-dll-node w1 primary )
    15171571    (let* ((n (set-element-addresses 0 primary)))
    1518       (setf (lap-instruction-opcode w1) (ash n (- arm::word-shift)))
     1572      (set-field-value w1 (byte 32 0) (ash n (- arm::word-shift)))
    15191573      (set-element-addresses n constant-pool)))
    15201574  ;; Now fix up label references.  Recall that the PC value at some
     
    15271581            (let* ((diff-in-bytes (- labaddr (+ 8 (lap-instruction-address insn)))))
    15281582              (case reftype
    1529                 (:b (setf (lap-instruction-opcode insn)
    1530                           (dpb (ash diff-in-bytes -2)
    1531                                (byte 24 0)
    1532                                (lap-instruction-opcode insn))))
     1583                (:b (set-field-value insn (byte 24 0) (ash diff-in-bytes -2)))
    15331584                (:mem12
    15341585                 (if (>= diff-in-bytes 0)
     
    15391590                 (set-field-value insn (byte 12 0) diff-in-bytes))
    15401591                (:offset
    1541                  (setf (lap-instruction-opcode insn)
    1542                        (1+ (ash (lap-instruction-address insn) (- arm::word-shift)))))
     1592                 (set-field-value insn (byte 32 0)(1+ (ash (lap-instruction-address insn) (- arm::word-shift)))))
    15431593                (t
    15441594                 (error "Label type ~s invalid or not yet supported."
     
    15861636
    15871637(defun make-arm-vinsn-instruction (opcode)
    1588   (let* ((head (list opcode)))
     1638  (let* ((head (list (cons (ldb (byte 16 16) opcode)
     1639                           (ldb (byte 16 0) opcode)))))
    15891640    (%make-arm-vinsn-instruction :head head :tail head)))
    15901641
     
    15971648  (car (avi-head avi)))
    15981649
    1599 (defun (setf avi-opcode) (new avi)
    1600   (setf (car (avi-head avi)) new))
    16011650
    16021651(defun set-avi-opcode-field (avi bytespec value)
    1603   (setf (avi-opcode avi)
    1604         (dpb value bytespec (avi-opcode avi)))
    1605   value)
     1652  (let* ((opcode (avi-opcode avi)))
     1653    (multiple-value-bind (high low)
     1654        (set-opcode-values (car opcode) (cdr opcode) bytespec value)
     1655      (declare (type (unsigned-byte 16) high low))
     1656      (setf (car opcode) high
     1657            (cdr opcode) low))
     1658    value))
     1659
     1660(defun get-avi-opcode-field (avi bytespec)
     1661  (let* ((opcode (avi-opcode avi)))
     1662    (get-opcode-field (car opcode) (cdr opcode) bytespec)))
    16061663
    16071664
     
    17501807                   (set-avi-opcode-field avi (byte 1 25) 1)
    17511808                   (set-avi-opcode-field avi (byte 12 0) constant))
    1752                  (let* ((op (ldb (byte 4 21) (avi-opcode avi)))
     1809                 (let* ((op (get-avi-opcode-field avi (byte 4 21)))
    17531810                        (newop nil))
    17541811                   (if (or (and (setq constant (encode-arm-immediate (lognot val)))
     
    18161873           (destructuring-bind (shift-count-form) (cdr shift-count)
    18171874             (vinsn-arg-or-constant avi shift-count-form vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7))))))
    1818       (setf (avi-opcode avi)
    1819             (set-opcode-value-from-addressing-mode (avi-opcode avi) op constant-index)))))
     1875      (let* ((opcode (avi-opcode avi)))
     1876        (setf (car opcode)
     1877              (the (unsigned-byte 16)
     1878                (set-opcode-value-from-addressing-mode
     1879                 (car opcode)
     1880                 op
     1881                 constant-index)))))))
    18201882
    18211883(defun vinsn-parse-reglist-operand (avi value vinsn-params)
     
    18251887        (add-avi-operand avi (encode-vinsn-field-type :reglist-bit) (list p))
    18261888        (let* ((bit (need-arm-gpr r)))
    1827           (setf (avi-opcode avi)
    1828                 (logior (avi-opcode avi) (ash 1 bit))))))))
     1889          (set-avi-opcode-field avi (byte 1 bit) 1))))))
    18291890
    18301891(defun vinsn-parse-rnw-operand (avi value vinsn-params)
     
    19321993                 (destructuring-bind (shift-count-form) (cdr shift-count)
    19331994                   (vinsn-arg-or-constant avi shift-count-form vinsn-params (encode-vinsn-field-type :shift-count) (byte 5 7))))))
    1934         (setf (avi-opcode avi)
    1935               (set-opcode-value-from-addressing-mode (avi-opcode avi) mode constant-index))))))
     1995        (setf (car (avi-opcode avi))
     1996              (the (unsigned-byte 16)
     1997              (set-opcode-value-from-addressing-mode (car (avi-opcode avi)) mode constant-index)))))))
     1998
     1999
    19362000
    19372001(defun vinsn-parse-dd-operand (avi value vinsn-params)
  • branches/arm/compiler/ARM/arm-lap.lisp

    r13981 r14042  
    8585
    8686
    87 
     87#+big-endian-host
     88(defun set-arm-code-vector-word (code-vector i insn)
     89  (setf (uvref code-vector i)
     90        (logior (ash (arm::lap-instruction-opcode-high insn) 16)
     91                         (arm::lap-instruction-opcode-low insn))))
     92
     93#+little-endian-host
     94(defun set-arm-code-vector-word (code-vector i insn)
     95  (declare (type (simple-array (unsigned-byte 16) (*)) code-vector)
     96           (fixnum i)
     97           (optimize (speed 3) (safety 0)))
     98  (let* ((j (+ i i)))
     99    (declare (fixnum j))
     100    (setf (aref code-vector j) (arm::lap-instruction-opcode-low insn)
     101          (aref code-vector (the fixnum (1+ j)))
     102          (arm::lap-instruction-opcode-high insn))))
     103   
     104 
    88105
    89106
     
    110127      (do-dll-nodes (insn seg)
    111128        (unless (eql (arm::instruction-element-size insn) 0)
    112           (setf (uvref code-vector i) (arm::lap-instruction-opcode insn))
     129          (set-arm-code-vector-word code-vector i insn)
    113130          (incf i)))
    114131      (dolist (immpair arm::*arm-constants*)
     
    142159       (arm::emit-lap-instruction-element
    143160        (let* ((insn (arm::make-lap-instruction nil)))
    144           (setf (arm::lap-instruction-opcode insn) (logand #xffffffff (eval arg)))
     161          (arm::set-field-value insn (byte 32 0) (logand #xffffffff (eval arg)))
    145162          insn)
    146163        current))
     
    148165      (:single
    149166       (check-usage :single)
    150        (append-dll-node
     167       (arm::emit-lap-instruction-element
    151168        (let* ((insn (arm::make-lap-instruction nil)))
    152           (setf (arm::lap-instruction-opcode insn) (single-float-bits (float (eval arg) 0.0f0)))
     169          (arm::set-field-value insn (byte 32 0) (single-float-bits (float (eval arg) 0.0f0)))
    153170          insn)
    154171        current))
     
    158175         (let* ((insnlow (arm::make-lap-instruction nil))
    159176                (insnhigh (arm::make-lap-instruction nil)))
    160            (setf (arm::lap-instruction-opcode insnlow) low
    161                  (arm::lap-instruction-opcode insnhigh) high)
    162            (append-dll-node insnlow current)
    163            (append-dll-node insnhigh current)))))
     177           (arm::set-field-value insnlow (byte 32 0) low)
     178           (arm::set-field-value insnhigh (byte 32 0) high)
     179           (arm::emit-lap-instruction-element insnlow current)
     180           (arm::emit-lap-instruction-element insnhigh current)))))
    164181    current))
    165182       
  • branches/arm/compiler/ARM/arm2.lisp

    r14036 r14042  
    49084908                 (:data (setq current (svref sections 1)))
    49094909                 (:word
    4910                   (let* ((insn (arm::make-lap-instruction nil)))
    4911                     (setf (arm::lap-instruction-opcode insn)
    4912                           (parse-operand-form (cadr f)))
     4910                  (let* ((insn (arm::make-lap-instruction nil))
     4911                         (val (parse-operand-form (cadr f))))
     4912                    (arm::set-field-value insn (byte 32 0) val)
    49134913                    (arm::emit-lap-instruction-element insn current)))
    49144914                 (t
    49154915                  (let* ((insn (arm::make-lap-instruction nil))
     4916                         (opcode (car f))
    49164917                         (operands (cdr f)))
    4917                     (setf (arm::lap-instruction-opcode insn) (car f))
     4918                    (setf (arm::lap-instruction-opcode-high insn) (car opcode)
     4919                          (arm::lap-instruction-opcode-low insn) (cdr opcode))
    49184920                    (when predicate
    49194921                      (funcall (svref operand-insert-functions
     
    49464948                 (if (atom f)
    49474949                   (compiler-bug "Invalid form in vinsn body: ~s" f)
    4948                    (if (atom (car f))
     4950                   (if (or (atom (car f))
     4951                           (typep (caar f) 'fixnum))
    49494952                     (expand-insn-form f)
    49504953                     (if (eval-predicate (car f))
Note: See TracChangeset for help on using the changeset viewer.