Changeset 13705


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.

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

Legend:

Unmodified
Added
Removed

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

    r13699 r13705  
    2626
    2727
    28 
    29 (defvar *arm-gprs* (make-hash-table :test #'equalp))
     28(defvar *standard-arm-register-names* ())
     29(defvar *arm-register-names* ())
     30
     31
     32(defun get-arm-register (name)
     33  (let* ((pair (assoc (string name) *arm-register-names* :test #'string-equal)))
     34    (if pair
     35      (cdr pair))))
    3036
    3137(defun get-arm-gpr (name)
    32   (values (gethash (string name)  *arm-gprs*)))
    33 
    34 
    35 (defun define-arm-gpr (name val)
    36   (etypecase val
    37     ((mod 16) (setf (gethash (string name) *arm-gprs*) val))
    38     (symbol (let* ((defined (get-arm-gpr val)))
    39               (if defined
    40                 (setf (gethash (string name) *arm-gprs*) defined)
    41                 (error "ARM register value ~s not defined" val))))))
     38  (let* ((value (get-arm-register name)))
     39    (and value (< value 16) value)))
     40                     
     41
     42;;; This allows redefinition, which might be helpful while
     43;;; boostrapping.  ARM-LAP-EQUATE-FORM checks for redefinition
     44;;; before calling this.
     45(defun define-arm-register (name val)
     46  (let* ((value (if (typep val 'fixnum) val (get-arm-gpr val)))
     47         (string (string name)))
     48    (unless value
     49      (error "invalid ARM register value ~d for ~s." val name))
     50    (let* ((pair (assoc string *arm-register-names* :test #'string-equal)))
     51      (if pair
     52        (progn
     53          (unless (eql (cdr pair) value)
     54            (when ccl::*cerror-on-constant-redefinition*
     55              (cerror "Redefine ARM register ~s to have value ~*~d."
     56                      "ARM register ~s currently has value ~d."
     57                      name (cdr pair) value)
     58              (setf (cdr pair) value)))
     59          (push (cons string value) *arm-register-names*))
     60        value))))
    4261
    4362(defmacro defarmgpr (name val)
    44   `(define-arm-gpr ',name ',val))
     63  `(defconstant ,name (define-arm-register ',name ',val)))
    4564
    4665(defarmgpr r0 0)
    … …  
    198217(defparameter *arm-subprims-base* (ash 4 12) )
    199218)
     219(defvar *arm-subprims*)
    200220
    201221;;; For now, nothing's nailed down and we don't say anything about
    … …  
    209229    (macrolet ((defarmsubprim (name)
    210230                   `(define-arm-subprim ',name)))
    211       (defparameter *arm-subprims*
     231      (setq *arm-subprims*
    212232        (vector
    213233         (defarmsubprim .SPjmpsym)
    … …  
    12011221  `(arm::%kernel-global ,name))
    12021222
    1203 (defarmarchmacro ccl::lfun-vector (fn)
    1204   fn)
     1223(defarmarchmacro ccl::lfun-vector (fun)
     1224  fun)
    12051225
    12061226(defarmarchmacro ccl::lfun-vector-lfun (lfv)

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

    r13699 r13705  
    4040      (error "Unknown ARM condition name ~s." name)))
    4141
     42(defvar *arm-constants* ())
     43(defvar *lap-labels* ())
     44
     45
    4246(defun arm-constant-index (form)
    43   (error "NYI"))
     47  (let* ((idx (or (assoc form *arm-constants* :test 'equal)
     48                  (let* ((n (length *arm-constants*)))
     49                    (push (cons form n) *arm-constants*)
     50                    n))))
     51    (+ (ash (+ idx 2) arm::word-shift)  ; skip entrypoint, codevector
     52       arm::misc-data-offset)))
     53
     54           
    4455
    4556(defun need-constant (form)
    … …  
    6677  operand-types)
    6778
     79(eval-when (:compile-toplevel :load-toplevel :execute)
     80
    6881(ccl::defenum (:prefix "ARM-OPERAND-TYPE-")
    6982  rd                                    ; destination register in bits 12:15
    … …  
    7689  uuo-unary                             ; constant in UUO bits 12:15
    7790  uuoB                                  ; GPR in UUO bits 12:15
    78  
     91  rm
     92  b
    7993)
    8094
    … …  
    89103    (:uuo-unary . ,arm-operand-type-uuo-unary)
    90104    (:uuoB . ,arm-operand-type-uuoB)
     105    (:rm . ,arm-operand-type-rm)
     106    (:b . ,arm-operand-type-b)
    91107    ))
    92108
    … …  
    117133            (setq mask (logior mask (encode-one-instruction-type n))))))
    118134      0)))
     135)
    119136
    120137(defmacro encode-arm-instruction-flag (name)
    … …  
    182199(define-arm-instruction ldmia   #x8900000 () :rnw :reglist)
    183200(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)
    184206
    185207;;; UUOs
    … …  
    237259              (dotimes (i prefix-len)
    238260                (setf (schar prefix i) (schar string i)))
    239               (if (setq template (gethash prefix *arm-instruction-templates*))
     261              (if (setq template
     262                        (progn
     263                          (setq ordinal (gethash prefix *arm-instruction-ordinals*))
     264                          (when ordinal
     265                            (svref *arm-instruction-table* ordinal))))
    240266                (if (logbitp (encode-arm-instruction-flag :non-conditional) (arm-instruction-template-flags template))
    241267                  (values nil nil nil)
    … …  
    547573  (set-field-value instruction 4 12 (need-arm-gpr form)))
    548574
     575(defun parse-rm-operand (form instruction)
     576  (set-field-value instruction 4 0 (need-arm-gpr form)))
     577
     578(defun parse-b-operand (form instruction)
     579  (lap-note-label-reference form instruction :b))
     580
     581
    549582
    550583
    … …  
    560593      parse-uuo-unary-operand
    561594      parse-uuob-operand
     595      parse-rm-operand
     596      parse-b-operand
    562597      ))
    563598
    … …  
    595630          insn)))))
    596631
     632;;; A label can only be emitted once.  Once it's been emitted, its pred/succ
     633;;; slots will be non-nil.
     634
     635(defun lap-label-emitted-p (lab)
     636  (not (null (lap-label-pred lab))))
     637
     638(defun %make-lap-label (name)
     639  (let* ((lab (ccl::alloc-dll-node *lap-label-freelist*)))
     640    (if lab
     641      (progn
     642        (setf (lap-label-address lab) nil
     643              (lap-label-refs lab) nil
     644              (lap-label-name lab) name)
     645        lab)
     646      (%%make-lap-label name))))
     647
     648(defun make-lap-label (name)
     649  (let* ((lab (%make-lap-label name)))
     650    (if (typep *lap-labels* 'hash-table)
     651      (setf (gethash name *lap-labels*) lab)
     652      (progn
     653        (push lab *lap-labels*)
     654        (if (> (length *lap-labels*) 255)
     655          (let* ((hash (make-hash-table :size 512 :test #'eq)))
     656            (dolist (l *lap-labels* (setq *lap-labels* hash))
     657              (setf (gethash (lap-label-name l) hash) l))))))
     658    lab))
     659
     660(defun find-lap-label (name)
     661  (if (typep *lap-labels* 'hash-table)
     662    (gethash name *lap-labels*)
     663    (car (member name *lap-labels* :test #'eq :key #'lap-label-name))))
     664
     665(defun lap-note-label-reference (labx insn type)
     666  (let* ((lab (or (find-lap-label labx)
     667                  (make-lap-label labx))))
     668    (push (cons insn type) (lap-label-refs lab))
     669    lab))
     670
    597671(provide "ARM-ASM")

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

    r13699 r13705  
    231231
    232232
    233 #+linuxarm-target
     233#+(or linuxarm-target (not arm-target))
    234234(defvar *linuxarm-backend*
    235235  (make-backend :lookup-opcode #'arm::lookup-arm-instruction
    … …  
    278278                :target-arch arm::*arm-target-arch*))
    279279
    280 #+linuxarm-target
     280#+(or linuxarm-target (not arm-target))
    281281(pushnew *linuxarm-backend* *known-arm-backends* :key #'backend-name)
    282282
    … …  
    289289(defun fixup-arm-backend ()
    290290  (dolist (b *known-arm-backends*)
    291     (setf (backend-lap-opcodes b) arm::*arm-opcodes*
     291    (setf (backend-lap-opcodes b) arm::*arm-instruction-table*
    292292          (backend-p2-dispatch b) *arm2-specials*
    293293          (backend-p2-vinsn-templates b)  *arm-vinsn-templates*)
    … …  
    301301#+arm-target
    302302(setq *host-backend* *arm-backend* *target-backend* *arm-backend*)
    303 #-arm-target
    304 (unless (backend-target-foreign-type-data *arm-backend*)
    305   (let* ((ftd (make-ftd
    306                :interface-db-directory
    307                #+darwinarm-target "ccl:darwin-headers;"
    308                #+linuxarm-target "ccl:headers;"
    309                :interface-package-name
    310                #+darwinarm-target "DARWIN32"
    311                #+linuxarm-target "LINUX32"
    312                :attributes
    313                #+darwinarm-target
    314                '(:signed-char t
    315                  :struct-by-value t
    316                  :prepend-underscores t
    317                  :bits-per-word  32
    318                  :poweropen-alignment t)
    319                #+linuxarm-target
    320                '(:bits-per-word 32)
    321                :ff-call-expand-function
    322                #+linuxarm-target
    323                'linux32::expand-ff-call
    324                #+darwinarm-target
    325                'darwin32::expand-ff-call
    326                :ff-call-struct-return-by-implicit-arg-function
    327                #+linuxarm-target
    328                linux32::record-type-returns-structure-as-first-arg
    329                #+darwinarm-target
    330                darwin32::record-type-returns-structure-as-first-arg
    331                :callback-bindings-function
    332                #+linuxarm-target
    333                linux32::generate-callback-bindings
    334                #+darwinarm-target
    335                darwin32::generate-callback-bindings
    336                :callback-return-value-function
    337                #+linuxarm-target
    338                linux32::generate-callback-return-value
    339                #+darwinarm-target
    340                darwin32::generate-callback-return-value
    341                )))
    342     (install-standard-foreign-types ftd)
    343     (use-interface-dir :libc ftd)
    344     (setf (backend-target-foreign-type-data *arm-backend*) ftd)))
     303
     304(defun setup-arm-ftd (backend)
     305  (or (backend-target-foreign-type-data backend)
     306      (let* ((name (backend-name backend))
     307             (ftd
     308              (case name
     309                (:darwinarm
     310                 (make-ftd :interface-db-directory "ccl:darwin-arm-headers;"
     311                           :interface-package-name "ARM-DARWIN"
     312                           :attributes '(:bits-per-word  32
     313                                         :signed-char t
     314                                         :struct-by-value t
     315                                         :prepend-underscore nil)
     316                           :ff-call-expand-function
     317                           (intern "EXPAND-FF-CALL" "ARM-DARWIN")
     318                           :ff-call-struct-return-by-implicit-arg-function
     319                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
     320                                   "ARM-DARWIN")
     321                           :callback-bindings-function
     322                           (intern "GENERATE-CALLBACK-BINDINGS" "ARM-DARWIN")
     323                           :callback-return-value-function
     324                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "ARM-DARWIN")))
     325                (:linuxarm
     326                 (make-ftd :interface-db-directory "ccl:arm-headers;"
     327                           :interface-package-name "ARM-LINUX"
     328                           :attributes '(:bits-per-word  32
     329                                         :signed-char nil
     330                                         :struct-by-value t
     331                                         :float-results-in-x87 t)
     332                           :ff-call-expand-function
     333                           (intern "EXPAND-FF-CALL" "ARM-LINUX")
     334                           :ff-call-struct-return-by-implicit-arg-function
     335                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
     336                                   "ARM-LINUX")
     337                           :callback-bindings-function
     338                           (intern "GENERATE-CALLBACK-BINDINGS" "ARM-LINUX")
     339                           :callback-return-value-function
     340                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "ARM-LINUX"))))))
     341        (install-standard-foreign-types ftd)
     342        (use-interface-dir :libc ftd)
     343        (setf (backend-target-foreign-type-data backend) ftd))))
    345344
    346345(pushnew *arm-backend* *known-backends* :key #'backend-name)
    347346
     347#+notyet
    348348(require "ARM-VINSNS")
    349349
    350 (defparameter *arm-backend*
    351   #+arm-target *arm-backend*
    352   #-(or arm-target)
    353   nil)
     350
    354351
    355352

  • 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)

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

    r13699 r13705  
    3131      (cmp nargs (:$ (ash ,min arm::fixnumshift)))
    3232      (uuo-error-wrong-nargs (:? ne)))
    33     `(trnei nargs ',min)
    3433    (if (null max)
    3534      (unless (= min 0)
    … …  
    243242      (push inst insts))))
    244243
    245 (defarmlapmacro get-single-float (dest node)
    246   (target-arch-case
    247    (:ppc32
    248     `(lfs ,dest ppc32::single-float.value ,node))
    249    (:ppc64
    250     `(progn
    251       (std ,node ppc64::tcr.single-float-convert ppc64::rcontext)
    252       (lfs ,dest ppc64::tcr.single-float-convert ppc64::rcontext)))))
     244(defarmlapmacro get-single-float (dest node temp)
     245  `(progn
     246    (ldr ,temp (:@ ,node (:$ arm::single-float.value)))
     247    (fmsr ,dest ,temp)))
    253248
    254249(defarmlapmacro get-double-float (dest node)
    255   (target-arch-case
    256    (:ppc32
    257     `(lfd ,dest ppc32::double-float.value ,node))
    258    (:ppc64
    259     `(lfd ,dest ppc64::double-float.value ,node))))
     250  `(progn
     251    (ldrdd imm0 imm1 (:@ ,node (:$ arm::double-float.value)))
     252    (fmdrr ,dest imm0 imm1)))
    260253 
    261254
    262 (defarmlapmacro put-single-float (src node)
    263   (target-arch-case
    264    (:ppc32
    265     `(stfs ,src ppc32::single-float.value ,node))
    266    (:ppc64
    267     `(progn
    268       (stfs ,src ppc64::tcr.single-float-convert ppc64::rcontext)
    269       (ld ,node ppc64::tcr.single-float-convert ppc64::rcontext)))))
     255(defarmlapmacro put-single-float (src node temp)
     256  `(progn
     257    (fmrs ,temp ,src)
     258    (str ,temp (:@ ,node (:$ arm::single-float.value))))
    270259
    271260(defarmlapmacro put-double-float (src node)
    272   (target-arch-case
    273    (:ppc32
    274     `(stfd ,src ppc32::double-float.value ,node))
    275    (:ppc64
    276     `(stfd ,src ppc64::double-float.value ,node))))
     261  `(progn
     262    (fmrrd imm0 imm1 ,src)
     263    (strdd imm0 imm1 (:@ ,node (:$ arm::double-float.value)))))
     264
    277265
    278266(defarmlapmacro clear-fpu-exceptions ()
    279   `(mtfsf #xfc #.ppc::fp-zero))
    280 
    281 
    282 
    283 ;;; from ppc-bignum.lisp
     267  (error "Later."))
     268
     269
     270
    284271(defarmlapmacro digit-h (dest src)
    285   (target-arch-case
    286    (:ppc32
    287     `(rlwinm ,dest ,src (+ 16 ppc32::fixnumshift) (- 16 ppc32::fixnumshift) (- 31 ppc32::fixnumshift)))
    288    (:ppc64
    289     (error "DIGIT-H on PPC64 ?"))))
    290 
    291 ;;; from ppc-bignum.lisp
     272  `(progn
     273    (mov ,dest (:$ (ash #xff arm::fixnumshift)))
     274    (orr ,dest ,dest (:lsl ,dest (:$ 8)))
     275    (and ,dest ,dest (:lsr ,src  (:$ (- 16 arm::fixnumshift))))))
     276
    292277(defarmlapmacro digit-l (dest src)
    293   (target-arch-case
    294    (:ppc32
    295     `(clrlslwi ,dest ,src 16 ppc32::fixnumshift))
    296    (:ppc64
    297     (error "DIGIT-L on PPC64 ?"))))
     278  `(progn
     279    (mov ,dest (:$ (ash #xff arm::fixnumshift)))
     280    (orr ,dest ,dest (:lsl ,dest (:$ 8)))
     281    (and ,dest ,dest (:lsl ,src  (:$ arm::fixnumshift)))))
    298282 
    299 ;;; from ppc-bignum.lisp
     283
    300284(defarmlapmacro compose-digit (dest high low)
    301   (target-arch-case
    302    (:ppc32
    303     `(progn
    304       (rlwinm ,dest ,low (- ppc32::nbits-in-word ppc32::fixnumshift) 16 31)
    305       (rlwimi ,dest ,high (- 16 ppc32::fixnumshift) 0 15)))
    306    (:ppc64
    307     (error "COMPOSE-DIGIT on PPC64 ?"))))
     285  ;; Can we assume that HIGH and LOW are boxed 16-bit fixnums ?
     286  ;; This code does ...
     287  `(progn
     288    (mov ,dest (:lsl ,high (:$ (- 16 arm::fixnumshift))))
     289    (orr ,dest ,dest (:lsr ,low (:$ arm::fixnumshift)))))
    308290
    309291(defarmlapmacro macptr-ptr (dest macptr)
    … …  
    323305         (one (gensym)))
    324306  `(progn
    325      (cmpri cr1 nargs '2)
    326      (cmpri cr0 nargs 0)
    327      (beq cr1 ,two)
    328      (beq cr0 ,none)
    329      (blt cr1 ,one)
    330      (vpush arg_x)
    331      ,two
    332      (vpush arg_y)
    333      ,one
    334      (vpush arg_z)
     307    (cmp nargs (:$ 0))
     308    (beq ,none)
     309    (cmp nargs '2)
     310    (strgt arg_x (:@! vsp (:$ (- arm::node-size))))
     311    (strge arg_y (:@! vsp (:$ (- arm::node-size))))
     312    (str arg_z (:@! vsp (:$ (- arm::node-size))))
    335313     ,none)))
    336314
Note: See TracChangeset for help on using the changeset viewer.