Ignore:
Timestamp:
May 18, 2010, 1:36:01 PM (10 years ago)
Author:
gb
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.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • 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
Note: See TracChangeset for help on using the changeset viewer.