Ignore:
Timestamp:
May 16, 2010, 1:51:57 AM (10 years ago)
Author:
gb
Message:

Keep inching forward, trying to work out assembler/LAP stuff, mostly.

File:
1 edited

Legend:

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

    r13699 r13705  
    3030(defun (setf arm-lap-macro-function) (def name)
    3131  (let* ((s (string name)))
    32     (when (gethash s arm::*arm-instruction-templates*)
     32    (when (gethash s arm::*arm-instruction-ordinals*)
    3333      (error "~s already defines an arm instruction . " name))
    3434    (setf (gethash s (backend-lap-macros *arm-backend*)) def)))
     
    4242
    4343(defvar *arm-lap-constants* ())
    44 (defvar *arm-lap-labels* ())
    45 (defvar *arm-lap-instructions*)
    4644(defvar *arm-lap-regsave-reg* ())
    4745(defvar *arm-lap-regsave-addr* ())
     
    5048
    5149
     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)))
    5263
    5364
     
    6677
    6778(defun %define-arm-lap-function (name body &optional (bits 0))
    68   (with-dll-node-freelist (*lap-instructions* *lap-instruction-freelist*)
     79  (with-dll-node-freelist (*lap-instructions* arm::*lap-instruction-freelist*)
    6980      (let* ((*lap-labels* ())
    70              (*arm-lap-constants* ())
     81             (arm::*arm-constants* ())
    7182             (*arm-lap-lfun-bits* bits))
    7283        (dolist (form body)
    7384          (arm-lap-form form))
    74         #+arm-lap-scheduler (arm-schedule-instuctions)       ; before resolving branch targets
    7585        (arm-lap-generate-code name (arm-lap-do-labels) *arm-lap-lfun-bits*))))
    7686
     
    8191    (declare (fixnum pc))
    8292    (do-dll-nodes (node *lap-instructions*)
    83       (setf (instruction-element-address node) pc)
    84       (if (typep node 'lap-label)
     93      (setf (arm::instruction-element-address node) pc)
     94      (if (typep node 'arm::lap-label)
    8595        (if delete-labels-p (remove-dll-node node))
    8696        (incf pc 4)))
     
    92102(defun arm-lap-do-labels ()
    93103  (do-lap-labels (lab)
    94     (if (and (lap-label-refs lab) (not (lap-label-emitted-p lab)))
     104    (if (and (arm::lap-label-refs lab) (not (arm::lap-label-emitted-p lab)))
    95105      (error "Label ~S was referenced but never defined. "
    96              (lap-label-name lab)))
     106             (arm::lap-label-name lab)))
    97107    ;; Repeatedly iterate through label's refs, until none of them is
    98108    ;; the preceding instruction.  This eliminates
     
    102112    ;; but can probably be fooled by hairier nonsense.
    103113    (loop
    104       (when (dolist (ref (lap-label-refs lab) t)
    105               (when (eq lab (lap-instruction-succ ref))
     114      (when (dolist (ref (arm::lap-label-refs lab) t)
     115              (when (eq lab (arm::lap-instruction-succ ref))
    106116                (remove-dll-node ref)
    107                 (setf (lap-label-refs lab) (delete ref (lap-label-refs lab)))
     117                (setf (arm::lap-label-refs lab) (delete ref (arm::lap-label-refs lab)))
    108118                (return)))
    109119        (return))))
    110120  ;; Assign pc to emitted labels, splice them out of the list.
    111121 
    112   (if (> (the fixnum (dll-header-length *lap-instructions*)) 8191)
    113     ;; -Might- have some conditional branches that are too long.
    114     ;; Definitely don't  otherwise, so only bother to check in this case
    115     (arm-lap-remove-long-branches)
    116     (arm-lap-assign-addresses t)))
     122    (arm-lap-assign-addresses t))
    117123
    118124;;; Replace each label with the difference between the label's address
     
    120126(defun arm-lap-resolve-labels ()
    121127  (do-lap-labels (label)
    122     (let* ((label-address (lap-label-address label)))
     128    (let* ((label-address (arm::lap-label-address label)))
    123129      (declare (fixnum label-address))          ; had BETTER be ...
    124       (dolist (insn (lap-label-refs label))
    125         (let* ((diff (- label-address (lap-instruction-address insn))))
     130      (dolist (insn (arm::lap-label-refs label))
     131        (let* ((diff (- label-address (arm::lap-instruction-address insn))))
    126132          (declare (fixnum diff))
    127           (let* ((opvals (lap-instruction-parsed-operands insn))
     133          (let* ((opvals (arm::lap-instruction-parsed-operands insn))
    128134                 (pos (position label opvals)))
    129135            (unless pos
     
    132138
    133139(defun arm-lap-generate-instruction (code-vector index insn)
    134   (let* ((op (lap-instruction-opcode insn))
     140  (let* ((op (arm::lap-instruction-opcode insn))
    135141         (vals (lap-instruction-parsed-operands insn))
    136142         (high (opcode-op-high op))
     
    156162     nil)))
    157163
    158 (defparameter *use-traceback-tables* nil)
    159 
    160 (defun traceback-fullwords (pname)
    161   (if (and *use-traceback-tables* pname (typep pname 'simple-base-string))
    162     (ceiling (+ 22 (length pname)) 4)
    163     0))
    164 
    165 (defun add-traceback-table (code-vector start pname)
    166   (flet ((out-byte (v i8 b)
    167             (declare (type (simple-array (unsigned-byte 8) (*)) v)
    168                     (optimize (speed 3) (safety 0))
    169                     (fixnum i8))
    170             (setf (aref v i8) b)))         
    171     (flet ((out-bytes (v i32 b0 b1 b2 b3)
    172            (declare (type (simple-array (unsigned-byte 8) (*)) v)
    173                     (optimize (speed 3) (safety 0))
    174                     (fixnum i32))
    175            (let* ((i8 (ash i32 2)))
    176              (declare (fixnum i8))
    177              (setf (aref v i8) b0
    178                    (aref v (%i+ i8 1)) b1
    179                    (aref v (%i+ i8 2)) b2
    180                    (aref v (%i+ i8 3)) b3))))
    181       (setf (uvref code-vector start) 0)
    182       (out-bytes code-vector (1+ start)
    183                  0                          ; traceback table version
    184                  0                          ; language id 7 - try 0 instead (means C) or 9 means C++
    185                  #x20                       ; ???
    186                  #x41)                      ; ???
    187       (out-bytes code-vector (+ start 2)
    188                  #x80 #x06 #x01 #x00)       ; ??? ??? ??? ???
    189       (setf (uvref code-vector (+ start 3)) #x0)
    190       (setf (uvref code-vector (+ start 4)) (ash start 2))
    191       (let* ((namelen (length pname))
    192              (pos (ash (the fixnum (+ start 5)) 2)))
    193         (declare (fixnum namelen pos))
    194         (out-byte code-vector pos (ldb (byte 8 8) namelen))
    195         (incf pos)
    196         (out-byte code-vector pos (ldb (byte 8 0) namelen))
    197         (incf pos)
    198         (dotimes (i namelen)
    199           (out-byte code-vector pos (char-code (schar pname i)))
    200           (incf pos))))))
    201 
    202 (defun arm-lap-generate-code (name maxpc bits &optional (traceback nil))
     164
     165
     166(defun arm-lap-generate-code (name maxpc bits)
    203167  (declare (fixnum maxpc))
    204168  (let* ((target-backend *target-backend*)
    205169         (cross-compiling (not (eq *host-backend* target-backend)))
    206          (traceback-size
    207           (traceback-fullwords (and traceback
    208                                     name
    209                                     (setq traceback (symbol-name name)))))
     170
    210171         (prefix (arch::target-code-vector-prefix (backend-target-arch *target-backend*)))
    211172         (prefix-size (length prefix))
    212          (code-vector-size (+ (ash maxpc -2) traceback-size prefix-size))
    213 
    214          (constants-size (+ 3 (length *arm-lap-constants*)))
     173         (code-vector-size (+ (ash maxpc -2) prefix-size))
     174
     175         (constants-size (+ 4 (length *arm-lap-constants*)))
    215176         (constants-vector (%alloc-misc
    216177                            constants-size
     
    220181         (i prefix-size))
    221182    (declare (fixnum i constants-size))
    222     #+arm32-target
    223     (if (>= code-vector-size (ash 1 19)) (compiler-function-overflow))
    224183    (let* ((code-vector (%alloc-misc
    225184                         code-vector-size
    226185                         (if cross-compiling
    227186                           target::subtag-xcode-vector
    228                            target::subtag-code-vector))))
     187                           arm::subtag-code-vector))))
    229188      (dotimes (j prefix-size)
    230189        (setf (uvref code-vector j) (pop prefix)))
     
    233192        (arm-lap-generate-instruction code-vector i insn)
    234193        (incf i))
    235       (unless (eql 0 traceback-size)
    236         (add-traceback-table code-vector i traceback))
     194
    237195      (dolist (immpair *arm-lap-constants*)
    238196        (let* ((imm (car immpair))
     
    252210(defun arm-lap-pseudo-op (form)
    253211  (case (car form)
    254     (:regsave
    255      (if *arm-lap-regsave-label*
    256        (warn "Duplicate :regsave form not handled (yet ?) : ~s" form)
    257        (destructuring-bind (reg addr) (cdr form)
    258          (let* ((regno (arm-register-name-or-expression reg)))
    259            (if (not (<= arm::save7 regno arm::save0))
    260              (warn "Not a save register: ~s.  ~s ignored." reg form)
    261              (let* ((addrexp (arm-register-name-or-expression addr)))   ; parses 'fixnum
    262                (if (not (and (typep addrexp 'fixnum)
    263                              (<= 0 addrexp #x7ffc)      ; not really right
    264                              (not (logtest 3 addrexp))))
    265                  (warn "Invalid logical VSP: ~s.  ~s ignored." addr form)
    266                  (setq *arm-lap-regsave-label* (emit-lap-label (gensym))
    267                        *arm-lap-regsave-reg* regno
    268                        *arm-lap-regsave-addr* (- (+ addrexp)
    269                                                  (* 4 (1+ (- arm::save0 regno))))))))))))
    270212    (:arglist (setq *arm-lap-lfun-bits* (encode-lambda-list (cadr form))))))
    271213
     
    287229                ((let) (arm-lap-equate-form (cadr form) (cddr form)))
    288230                (t
    289                  ; instruction macros expand into instruction forms
    290                  ; (with some operands reordered/defaulted.)
    291                  (let* ((expander (arm::arm-macro-function name)))
    292                    (if expander
    293                      (arm-lap-form (funcall expander form nil))
    294                      (arm-lap-instruction name (cdr form)))))))))))))
     231                 (arm-lap-instruction name (cdr form)))))))))))
    295232
    296233;;; (let ((name val) ...) &body body)
    297234;;; each "val" gets a chance to be treated as a ARM register name
    298235;;; before being evaluated.
    299 (defun arm-lap-equate-form (eqlist body)
    300   (let* ((symbols (mapcar #'(lambda (x)
    301                               (let* ((name (car x)))
    302                                 (or
    303                                  (and name
    304                                       (symbolp name)
    305                                       (not (constant-symbol-p name))
    306                                       name)
    307                                  (error
    308                                   "~S is not a bindable symbol name ." name))))
    309                           eqlist))
    310          (values (mapcar #'(lambda (x) (or (arm-vr-name-p (cadr x))
    311                                            (arm-fpr-name-p (cadr x))
    312                                            (arm-register-name-or-expression
    313                                             (cadr x))))
    314                          eqlist)))
    315     (progv symbols values
    316                    (dolist (form body)
    317                      (arm-lap-form form)))))
     236(defun arm-lap-equate-form (eqlist body)
     237  (collect ((symbols)
     238            (values))
     239    (let* ((arm::*arm-register-names* arm::*arm-register-names*))
     240      (dolist (pair eqlist)
     241        (destructuring-bind (symbol value) pair
     242          (unless (and symbol
     243                       (symbolp symbol)
     244                       (not (constant-symbol-p symbol))
     245                       (not (arm::get-arm-register symbol)))
     246            (error "~s is not a bindable symbol name . " symbol))
     247          (let* ((regval (arm::get-arm-register value)))
     248            (if regval
     249              (arm::define-arm-register symbol regval)
     250              (progn
     251                (symbols symbol)
     252                (values (eval value)))))))
     253
     254    (progv (symbols) (values)
     255      (dolist (form body)
     256        (arm-lap-form form))))))
    318257
    319258(defun arm-lap-constant-offset (x)
Note: See TracChangeset for help on using the changeset viewer.