Changeset 13763


Ignore:
Timestamp:
Jun 1, 2010, 11:22:40 AM (9 years ago)
Author:
gb
Message:

Still changing too much to make changes notable.

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

Legend:

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

    r13751 r13763  
    2222
    2323(defparameter *arm-condition-names* '(("eq" . 0) ("ne" . 1)
    24                                       ("cc" . 2) ("hs" . 2) ("cs" . 3) ("lo" . 3)
     24                                      ("hs" . 2) ("cc" . 2) ("lo" . 3) ("cs" . 3)
    2525                                      ("mi" . 4) ("pl" . 5)
    2626                                      ("vs" . 6) ("vc" . 7)
     
    493493   (define-arm-instruction ldrd  (:rde :mem8)
    494494     #x000000d0
    495      #x0e3000f0
     495     #x0e1000f0
    496496     ())
    497497   (define-arm-instruction strd  (:rde :mem8)
    498498     #x000000f0
    499      #x0e3000f0
     499     #x0e4000f0
    500500     ())
    501501
     
    660660     #x0fbf0fc0
    661661     ())
     662   (define-arm-instruction smull (:rd :rn :rm :rn)
     663     #x0c000090
     664     #x0ff000f0
     665     ())
     666   (define-arm-instruction smulls (:rd :rn :rm :rn)
     667     #x0c000090
     668     #x0ff000f0
     669     ())   
    662670   ))
    663671
     
    10531061        (set-field-value instruction (byte 4 16) (need-arm-gpr rn))
    10541062        (cond ((atom index)
    1055                (set-field-value instruction (byte 4 0) (need-arm-gpr index))
    1056                (set-field-value instruction (byte 25 1) 1))
     1063               (set-field-value instruction (byte 4 0) (need-arm-gpr index)))
    10571064              (t (unless (eq (keywordize (car index)) :$)
    10581065                   (error "Invalid index: ~s." index))
     
    10621069                     (if (< value 0)
    10631070                       (setq value (- value))
    1064                        (set-field-value instruction (byte 23 1) 1))
     1071                       (set-field-value instruction (byte 1 23) 1))
     1072                     (set-field-value instruction (byte 1 22) 1)
    10651073                     (set-field-value instruction (byte 4 0) (ldb (byte 4 0) value))
    10661074                     (set-field-value instruction (byte 4 8) (ldb (byte 4 4) value)))))))
    1067     (set-addressing-mode instruction mode constant-index))))
     1075      (set-addressing-mode instruction mode constant-index))))
    10681076
    10691077(defun parse-dd-operand (form instruction)
     
    14491457                       (error "Unknown operand: ~s" op)))))
    14501458               (if (eq (car op) :apply)
    1451                  `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op)))))))
     1459                 `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op)))
     1460                 (eval op)))))
    14521461    `(,(cadr form) ,@(mapcar #'simplify-operand (cddr form)))))
    14531462
     
    15221531
    15231532(defun vinsn-parse-m12-operand (avi value vinsn-params)
    1524 
    15251533  (when (typep value 'keyword)
    15261534    (setq value `(:@ arm::pc (:$ ,value))))
     
    16071615           (add-avi-operand avi (encode-vinsn-field-type :label) addr))
    16081616          ((arm-subprimitive-name value)
    1609            (add-avi-operand avi (encode-vinsn-field-type :label) addr))
     1617           (add-avi-operand avi (encode-vinsn-field-type :label) value))
    16101618          (t
    16111619           (error "Unknown branch target: ~s." value)))))
     
    16321640      (vinsn-arg-or-gpr avi rn vinsn-params (encode-vinsn-field-type :rn) (byte 4 16))
    16331641      (let* ((constant-index (and (consp index) (eq (car index) :$))))
    1634         (unless constant-index
    1635           (set-avi-opcode-field avi (byte 25 1) 1))
     1642        (when constant-index
     1643          (set-avi-opcode-field avi (byte 1 22) 1))
    16361644        (cond ((atom index)
    16371645               (vinsn-arg-or-gpr avi index vinsn-params (encode-vinsn-field-type :rm) (byte 4 0)))
     
    18211829(defun vinsn-insert-label-operand (instruction value)
    18221830  (let* ((label (etypecase value
     1831                  (cons (or (find-lap-label value)
     1832                            (error "No LAP label for ~s." (car value))))
    18231833                  (lap-label value)
    18241834                  (ccl::vinsn-label
     
    18351845
    18361846(defun vinsn-insert-data-label-operand (instruction value)
    1837   )
     1847  (let* ((label (if (typep value 'lap-label) value (find-lap-label value))))
     1848    (unless label
     1849      (error "Mystery data label: ~s" value))
     1850    (push (cons instruction :mem12) (lap-label-refs label))))
    18381851
    18391852(defun vinsn-insert-dd-operand (instruction value)
  • branches/arm/compiler/ARM/arm-vinsns.lisp

    r13751 r13763  
    14081408  (cmp arg0 arg1))
    14091409
    1410 (define-arm-vinsn compare-signed-s16const (()
     1410(define-arm-vinsn compare-signed-s16const (((crf :crf))
    14111411                                           ((arg0 :imm)
    14121412                                            (imm :s16const))
     
    15301530  (stmdb (:! vsp) (arg_z arg_y)))
    15311531
    1532    
     1532(define-arm-vinsn (vpush-argregs :push :node :vsp) (()
     1533                                                    ((num-fixed-args :u16const)))
     1534  ((:pred = num-fixed-args 0)
     1535   (cmp nargs (:$ 0))
     1536   (beq :done))
     1537  ((:pred < num-fixed-args 2)
     1538   (cmp nargs (:$ (ash 2 arm::fixnumshift)))
     1539   (strlo arg_z (:@! vsp (:$ (- arm::node-size))))
     1540   (stmeq (:! vsp) (arg_z arg_y))
     1541   (stmhi (:! vsp) (arg_z arg_y arg_x))
     1542   :done)
     1543  ((:pred = num-fixed-args 2)
     1544   (cmp nargs (:$ (ash 2 arm::fixnumshift)))
     1545   (stmeq (:! vsp) (arg_z arg_y))
     1546   (stmhi (:! vsp) (arg_z arg_y arg_x)))
     1547  ((:pred > num-fixed-args 2)
     1548   (stm (:! vsp) (arg_z arg_y arg_x))))
     1549
    15331550
    15341551(define-arm-vinsn (vpop-register :pop :node :vsp)
     
    17251742    (mvn dest (:$ (:apply lognot intval))))
    17261743   ((:not (:pred arm::encode-arm-immediate (:apply lognot intval)))
    1727     (:section :data)
     1744    (:data)
    17281745    :const
    17291746    (:word intval)
    1730     (:section :text)
     1747    (:code)
    17311748    (ldr dest :const))))
    17321749
    17331750
    1734 #+notyet
    1735 (define-arm-vinsn (discard-temp-frame :tsp :pop :discard) (()
    1736                                                            ())
    1737   (ldr arm::tsp (:@ arm::tsp (:$ 0))))
     1751
    17381752
    17391753
     
    18411855 
    18421856  (sub allocptr allocptr (:$ (:apply logand #xff
    1843                                  (:apply -
    1844                                     (:apply logand (lognot 7)
    1845                                     (:apply + (+ 7 4) nbytes))
    1846                                     arm::fulltag-misc))))
     1857                                     (:apply -
     1858                                             (:apply logand (lognot 7)
     1859                                                     (:apply + (+ 7 4) nbytes))
     1860                                             arm::fulltag-misc))))
    18471861  ((:pred > (:apply -
    18481862                    (:apply logand (lognot 7)
     
    18501864                    arm::fulltag-misc) #xff)
    18511865   (sub allocptr allocptr (:$ (:apply logand #xff00
    1852                                  (:apply -
    1853                                     (:apply logand (lognot 7)
    1854                                     (:apply + (+ 7 4) nbytes))
    1855                                     arm::fulltag-misc)))))
     1866                                      (:apply -
     1867                                              (:apply logand (lognot 7)
     1868                                                      (:apply + (+ 7 4) nbytes))
     1869                                              arm::fulltag-misc)))))
    18561870  (ldr dest (:@ rcontext (:$ arm::tcr.save-allocbase)))
    18571871  (cmp allocptr dest)
     
    32843298(define-arm-subprim-call-vinsn (destructuring-bind) .SPdestructuring-bind)
    32853299
    3286 (define-arm-subprim-call-vinsn (simple-keywords) .SPsimple-keywords)
    3287 
    3288 (define-arm-subprim-call-vinsn (keyword-args) .SPkeyword-args)
    32893300
    32903301(define-arm-subprim-call-vinsn (keyword-bind) .SPkeyword-bind)
     
    33053316
    33063317(define-arm-subprim-call-vinsn (gvector) .SPgvector)
     3318
     3319(define-arm-subprim-call-vinsn (discard-temp-frame) .SPdiscard_stack_object)
    33073320
    33083321(define-arm-vinsn (nth-value :call :subprim-call) (((result :lisp))
  • branches/arm/compiler/ARM/arm2.lisp

    r13751 r13763  
    1 ;;-*-Mode: LISP; Package: CCL -*-
     1;;;-*-Mode: LISP; Package: CCL -*-
    22;;;
    33;;;   Copyright (C) 2010 Clozure Associates
     
    316316    (:GE (values arm::arm-cond-ge t))))
    317317
    318 ;;; Generate the start and end bits for a RLWINM instruction that
    319 ;;; would be equivalent to to LOGANDing the constant with some value.
    320 ;;; Return (VALUES NIL NIL) if the constant contains more than one
    321 ;;; sequence of consecutive 1-bits, else bit indices.
    322 ;;; The caller generally wants to treat the constant as an (UNSIGNED-BYTE 32);
    323 ;;; since this uses LOGCOUNT and INTEGER-LENGTH to find the significant
    324 ;;; bits, it ensures that the constant is a (SIGNED-BYTE 32) that has
    325 ;;; the same least-significant 32 bits.
    326 (defun arm2-mask-bits (constant)
    327   (if (< constant 0) (setq constant (logand #xffffffff constant)))
    328   (if (= constant #xffffffff)
    329     (values 0 31)
    330     (if (zerop constant)
    331       (values nil nil)
    332       (let* ((signed (if (and (logbitp 31 constant)
    333                               (> constant 0))
    334                        (- constant (ash 1 32))
    335                        constant))
    336              (count (logcount signed))
    337              (len (integer-length signed))
    338              (highbit (logbitp (the fixnum (1- len)) constant)))
    339         (declare (fixnum count len))
    340         (do* ((i 1 (1+ i))
    341               (pos (- len 2) (1- pos)))
    342              ((= i count)
    343               (let* ((start (- 32 len))
    344                      (end (+ count start)))
    345                 (declare (fixnum start end))
    346                 (if highbit
    347                   (values start (the fixnum (1- end)))
    348                   (values (logand 31 end)
    349                           (the fixnum (1- start))))))
    350           (declare (fixnum i pos))
    351           (unless (eq (logbitp pos constant) highbit)
    352             (return (values nil nil))))))))
     318(defun acode-condition-to-arm-unsigned-cr-bit (cond)
     319  (condition-to-arm-unsigned-cr-bit cond))
     320
     321(defun condition-to-arm-unsigned-cr-bit (cond)
     322  (case cond
     323    (:EQ (values arm::arm-cond-eq t))
     324    (:NE (values arm::arm-cond-ne t))
     325    (:GT (values arm::arm-cond-hi t))
     326    (:LE (values arm::arm-cond-ls t))
     327    (:LT (values arm::arm-cond-lo t))
     328    (:GE (values arm::arm-cond-hs t))))
     329
     330
    353331   
    354332
     
    542520      (unless (eql i gpr)
    543521        (when (and (logbitp i *arm2-gpr-locations-valid-mask*)
    544                    (eql loc (svref *arm2-gpr-locations* i)))
    545           (setq *arm2-gpr-locations-valid-mask* (logandc2 *arm2-gpr-locations-valid-mask* (ash 1 i))))))
    546     (setf (svref *arm2-gpr-locations* gpr) loc)
     522                   (memq loc (svref *arm2-gpr-locations* i)))
     523          (when (null (setf (svref *arm2-gpr-locations* i)
     524                            (delete loc (svref *arm2-gpr-locations* i))))
     525            (setq *arm2-gpr-locations-valid-mask* (logandc2 *arm2-gpr-locations-valid-mask* (ash 1 i)))))))
     526    (if (logbitp gpr *arm2-gpr-locations-valid-mask*)
     527      (push loc (svref *arm2-gpr-locations* gpr))
     528      (setf (svref *arm2-gpr-locations* gpr) (list loc)))
     529   
    547530    (setq *arm2-gpr-locations-valid-mask* (logior *arm2-gpr-locations-valid-mask* (ash 1 gpr)))))
    548531 
     
    550533(defun arm2-regmap-note-reg-location (gpr loc)
    551534  (let* ((gpr (%hard-regspec-value gpr)))
    552     (setf (svref *arm2-gpr-locations* gpr) loc)
     535    (if (logbitp gpr *arm2-gpr-locations-valid-mask*)
     536      (push loc (svref *arm2-gpr-locations* gpr))
     537      (setf (svref *arm2-gpr-locations* gpr) (list loc)))
    553538    (setq *arm2-gpr-locations-valid-mask* (logior *arm2-gpr-locations-valid-mask* (ash 1 gpr))))) 
    554539 
     
    560545      (dotimes (i 16 (setq *arm2-gpr-locations-valid-mask* mask))
    561546        (when (logbitp i mask)
    562           (let* ((loc (svref info i)))
    563             (when (>= loc new)
     547          (let* ((locs (svref info i))
     548                 (head (cons nil locs))
     549                 (tail head))
     550            (declare (dynamic-extent head))
     551            (dolist (loc locs)
     552              (if (>= loc new)
     553                (setf (cdr tail) (cddr tail))
     554                (setq tail (cdr tail))))
     555            (when (null (setf (svref info i) (cdr head)))
    564556              (setq mask (logandc2 mask (ash 1 i)))))))))))
    565557
     
    688680;;; to compute/copy than to load it, anyway.)
    689681
     682#+maybe-later-that-same-day
    690683(defun arm2-restore-nvrs (seg ea nregs &optional from-fp)
    691684  (when (null from-fp)
     
    11421135           (regno (%hard-regspec-value reg)))
    11431136      (unless (and (logbitp regno mask)
    1144                    (eql offset (svref info regno)))
     1137                   (memq offset (svref info regno)))
    11451138        (let* ((other (dotimes (i 16)
    11461139                        (when (and (logbitp i mask)
    1147                                    (eql offset (svref info i)))
     1140                                   (memq offset (svref info i)))
    11481141                          (return i)))))
    11491142          (cond (other
     
    11521145                         (logior mask (ash 1 regno)))
    11531146                   (setf (svref info regno)
    1154                          (svref info other))
     1147                         (copy-list (svref info other)))
    11551148                   vinsn))
    11561149                (t
     
    11581151                   (setq *arm2-gpr-locations-valid-mask*
    11591152                         (logior mask (ash 1 regno)))
    1160                    (setf (svref info regno) offset)
     1153                   (setf (svref info regno) (list offset))
    11611154                   vinsn))))))))
    11621155
     
    31713164       (with-crf-target () crf
    31723165         (! compare crf ireg jreg)
    3173          (ensuring-node-target (target dest)
    3174            (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))))
     3166         (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1)))
    31753167         (^)))
    31763168      (^))))
     
    32273219     (vreg dest)
    32283220     (progn
    3229        (! compare-signed-s16const dest reg zero)
     3221       (if (or (arm::encode-arm-immediate zero)
     3222               (arm::encode-arm-immediate (lognot zero)))
     3223         (! compare-signed-s16const dest reg zero)
     3224         (with-node-target (reg) other
     3225           (arm2-lri seg other zero)
     3226           (! compare dest reg other)))
    32303227       (^ cr-bit true-p))
    3231      (with-imm-temps (reg) (b31-reg scaled)
    3232        (if (zerop zero)
    3233          (setq scaled reg)
    3234          (! subtract-constant scaled reg zero))
    3235        (ecase cr-bit
    3236          (#. arm::arm-cond-eq
    3237           (if true-p
    3238             (! eq0->bit31 b31-reg scaled)
    3239             (! ne0->bit31 b31-reg scaled)))
    3240          (#. arm::arm-cond-lt
    3241           (if true-p
    3242             (! lt0->bit31 b31-reg scaled)
    3243             (! ge0->bit31 b31-reg scaled)))
    3244          (#. arm::arm-cond-gt
    3245           (if true-p
    3246             (! gt0->bit31 b31-reg scaled)
    3247             (! le0->bit31 b31-reg scaled))))
    3248           (ensuring-node-target (target dest)
    3249             (! lowbit->truth target b31-reg))
     3228     (with-crf-target () crf
     3229       (if (or (arm::encode-arm-immediate zero)
     3230               (arm::encode-arm-immediate (lognot zero)))
     3231         (! compare-signed-s16const crf reg zero)
     3232         (with-node-target (reg) other
     3233           (arm2-lri seg other zero)
     3234           (! compare crf reg other)))
     3235       (ensuring-node-target (target dest)
     3236         (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))))
    32503237       (^)))))
    32513238
     
    48154802  (or (eq cd $backend-return) (arm2-mvpass-p cd)))
    48164803
    4817 (defun arm2-expand-note (note header)
     4804(defun arm2-expand-note (header note)
    48184805  (let* ((lab (vinsn-note-label note)))
    48194806    (case (vinsn-note-class note)
     
    50605047                  (! default-optionals (+ num-fixed num-opt)))
    50615048                (when keys
     5049                  (unless opt
     5050                    (! vpush-argregs num-fixed))
    50625051                  (let* ((keyvect (%car (%cdr (%cdr (%cdr (%cdr keys))))))
    50635052                         (flags (the fixnum (logior (the fixnum (if rest 4 0))
     
    50685057                    (dotimes (i (the fixnum (+ nkeys nkeys)))
    50695058                      (arm2-new-vstack-lcell :reserved *arm2-target-lcell-size* 0 nil))
    5070                     (! misc-ref-c-node arm::temp3 arm::nfn (1+ (backend-immediate-index keyvect)))
    5071                     (arm2-lri seg arm::imm2 (ash flags *arm2-target-fixnum-shift*))
    5072                     (arm2-lri seg arm::imm3 (ash nkeys *arm2-target-fixnum-shift*))
    5073                     (unless (= nprev 0)
    5074                       (arm2-lri seg arm::imm0 (ash nprev *arm2-target-fixnum-shift*)))
    5075                     (if (= 0 nprev)
    5076                       (! simple-keywords)
    5077                       (if (= 0 num-opt)
    5078                         (! keyword-args)
    5079                         (! keyword-bind)))))
     5059                    (backend-immediate-index keyvect)
     5060                    (arm2-lri seg arm::arg_y (ash flags *arm2-target-fixnum-shift*))
     5061                    (arm2-lri seg arm::imm0 (ash nprev *arm2-target-fixnum-shift*))
     5062                    (! keyword-bind)))
    50805063                (when rest
    50815064                  ;; If any keyword-binding's happened, the key/value
     
    64086391           (let* ((other (if (and fix1
    64096392                                  (typep (ash fix1 *arm2-target-fixnum-shift*)
    6410                                          '(signed-byte 32)))
     6393                                         '(signed-byte 32))
     6394                                  (or (arm::encode-arm-immediate
     6395                                       (ash fix1 *arm2-target-fixnum-shift*))
     6396                                      (arm::encode-arm-immediate
     6397                                       (- (ash fix1 *arm2-target-fixnum-shift*)))))
    64116398                           form2
    64126399                           (if (and fix2
    64136400                                    (typep (ash fix2 *arm2-target-fixnum-shift*)
    6414                                            '(signed-byte 32)))
     6401                                           '(signed-byte 32))
     6402                                    (or (arm::encode-arm-immediate
     6403                                         (ash fix2 *arm2-target-fixnum-shift*))
     6404                                        (arm::encode-arm-immediate
     6405                                         (- (ash fix2 *arm2-target-fixnum-shift*)))))
    64156406                             form1))))
    64166407             (if (and fix1 fix2)
     
    64186409               (if other
    64196410                 (let* ((constant (ash (or fix1 fix2) *arm2-target-fixnum-shift*))
    6420                         (reg (arm2-one-untargeted-reg-form seg other arm::arg_z))
    6421                         (high (ldb (byte 16 16) constant))
    6422                         (low (ldb (byte 16 0) constant)))
    6423                    (declare (fixnum high low))
     6411                        (reg (arm2-one-untargeted-reg-form seg other arm::arg_z)))
    64246412                   (if (zerop constant)
    64256413                     (<- reg)
    6426                      (progn
    6427                        (if (logbitp 15 low) (setq high (ldb (byte 16 0) (1+ high))))
    6428                        (if (and (eq vreg reg) (not (zerop high)))
    6429                          (with-node-temps (vreg) (temp)
    6430                            (! add-immediate temp reg high low)
    6431                            (<- temp))
    6432                          (ensuring-node-target (target vreg)
    6433                            (! add-immediate target reg high low))))))
     6414                     (ensuring-node-target (target vreg)
     6415                       (! add-immediate target reg constant))))
    64346416                 (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg form1 arm::arg_y form2 arm::arg_z)
    64356417                   (ensuring-node-target (target vreg)
Note: See TracChangeset for help on using the changeset viewer.