Ignore:
Timestamp:
May 30, 2010, 2:36:13 PM (9 years ago)
Author:
gb
Message:

Some stuff compiles; still a lot of work to do.
Try to reduce stack traffic in some simple cases by tracking which
registers contain copies of which stack locations. Should try to
exploit this further (and port to other platforms when it's working
reliably.)
Todo: well, a very long list of things, but one that seems obvious
is to try to use predication (at the vinsn level) to reduce the number
of conditional branches.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/arm/compiler/ARM/arm2.lisp

    r13741 r13751  
    1 ;;;-*-Mode: LISP; Package: CCL -*-
     1;;-*-Mode: LISP; Package: CCL -*-
    22;;;
    3 ;;;   Copyright (C) 2009 Clozure Associates
    4 ;;;   Copyright (C) 1994-2001 Digitool, Inc
     3;;;   Copyright (C) 2010 Clozure Associates
    54;;;   This file is part of Clozure CL. 
    65;;;
     
    6362                    (unless ,template-temp
    6463                      (warn "VINSN \"~A\" not defined" ,template-name-var))
    65                     `(%emit-vinsn ,',segvar ',,template-name-var (backend-p2-vinsn-templates *target-backend*) ,@,args-var))))
     64                    `(arm2-update-regmap (%emit-vinsn ,',segvar ',,template-name-var (backend-p2-vinsn-templates *target-backend*) ,@,args-var)))))
    6665       (macrolet ((<- (,retvreg-var)
    6766                    `(arm2-copy-register ,',segvar ,',vreg-var ,,retvreg-var))
    6867                  (@  (,labelnum-var)
    69                     `(backend-gen-label ,',segvar ,,labelnum-var))
     68                    `(progn
     69                      (arm2-invalidate-regmap)
     70                      (backend-gen-label ,',segvar ,,labelnum-var)))
    7071                  (-> (,label-var)
    7172                    `(! jump (aref *backend-labels* ,,label-var)))
     
    116117(defvar *arm2-register-restore-ea* nil)
    117118(defvar *arm2-compiler-register-save-label* nil)
    118 (defvar *arm2-valid-register-annotations* 0)
    119 (defvar *arm2-register-annotation-types* nil)
    120 (defvar *arm2-register-ea-annotations* nil)
    121119
    122120(defparameter *arm2-tail-call-aliases*
     
    163161
    164162(defvar *arm2-result-reg* arm::arg_z)
     163(defvar *arm2-gpr-locations* nil)
     164(defvar *arm2-gpr-locations-valid-mask* 0)
    165165
    166166
     
    374374           (*arm2-register-restore-count* nil)
    375375           (*arm2-compiler-register-save-label* nil)
    376            (*arm2-valid-register-annotations* 0)
    377            (*arm2-register-ea-annotations* (arm2-make-stack 16))
    378376           (*arm2-register-restore-ea* nil)
    379377           (*arm2-vstack* 0)
     
    397395           (*backend-fp-temps* arm-temp-fp-regs)
    398396           (*available-backend-fp-temps* arm-temp-fp-regs)
     397           (*backend-crf-temps* arm-cr-fields)
     398           (*available-backend-crf-temps* arm-cr-fields)
    399399           (bits 0)
    400400           (*logical-register-counter* -1)
     
    426426           (*arm2-fcells* (afunc-fcells afunc))
    427427           *arm2-recorded-symbols*
    428            (*arm2-emitted-source-notes* '()))
     428           (*arm2-emitted-source-notes* '())
     429           (*arm2-gpr-locations-valid-mask* 0)
     430           (*arm2-gpr-locations* (make-array 16 :initial-element nil)))
     431      (declare (dynamic-extent *arm2-gpr-locations*))
    429432      (set-fill-pointer
    430433       *backend-labels*
     
    490493    afunc))
    491494
    492 (defun arm2-xmake-function (code data labels imms bits)
    493   (let* ((arm::*lap-labels* labels)
    494          (cross-compiling (target-arch-case
    495                            (:arm (not (eq *host-backend* target-backend)))
    496                            (t t)))
    497          (numimms (length imms))
    498          (function (%alloc-misc (+ numimms 3)
    499                                 (if cross-compiling
    500                                   target::subtag-xfunction
    501                                   target::subtag-function))))
    502     (dotimes (i numimms)
    503       (setf (uvref function (1+ 2)) (aref imms i)))
    504     (setf (uvref function (+ numimms 1)) bits)
    505     (let* ((code-vector-size (arm::arm-finalize code data))
    506            (code-vector (%alloc-misc code-vector-size
    507                                      (if cross-compiling
    508                                        target::subtag-xcode-vector
    509                                        target::subtag-code-vector)))
    510            (j 0))
    511       (dotimes (i prefix-size)
    512         (setf (uvref code-vector i) (pop prefix)))
    513       (arm-lap-resolve-labels)
    514       (do-dll-nodes (insn *lap-instructions*)
    515         (arm-lap-generate-instruction code-vector i insn)
    516         (incf i))
    517       (setf (uvref function 1) code-vector)
    518       (%make-code-executable code-vector)
    519       function)))
     495(defun arm2-xmake-function (code data imms bits)
     496  (collect ((lap-imms))
     497    (dotimes (i (length imms))
     498      (lap-imms (cons (aref imms i) i)))
     499    (let* ((arm::*arm-constants* (lap-imms)))
     500      (arm-lap-generate-code code
     501                             (arm::arm-finalize code data)
     502                             bits))))
     503
     504
    520505     
    521506   
     
    538523              (if (eq (%svref v i) ref)
    539524                (setf (%svref v i) ref-fun)))))))))
     525
     526(eval-when (:compile-toplevel)
     527  (declaim (inline arm2-invalidate-regmap)))
     528
     529(defun arm2-invalidate-regmap ()
     530  (setq *arm2-gpr-locations-valid-mask* 0))
     531
     532(defun arm2-update-regmap (vinsn)
     533  (if (vinsn-attribute-p vinsn :call :jump)
     534    (arm2-invalidate-regmap)
     535    (setq *arm2-gpr-locations-valid-mask* (logandc2 *arm2-gpr-locations-valid-mask* (vinsn-gprs-set vinsn))))
     536  vinsn)
     537
     538(defun arm2-regmap-note-store (gpr loc)
     539  (let* ((gpr (%hard-regspec-value gpr)))
     540    ;; Any other GPRs that had contained loc no longer do so.
     541    (dotimes (i 16)
     542      (unless (eql i gpr)
     543        (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)
     547    (setq *arm2-gpr-locations-valid-mask* (logior *arm2-gpr-locations-valid-mask* (ash 1 gpr)))))
     548 
     549;;; For vpush: nothing else should claim to contain loc.
     550(defun arm2-regmap-note-reg-location (gpr loc)
     551  (let* ((gpr (%hard-regspec-value gpr)))
     552    (setf (svref *arm2-gpr-locations* gpr) loc)
     553    (setq *arm2-gpr-locations-valid-mask* (logior *arm2-gpr-locations-valid-mask* (ash 1 gpr))))) 
     554 
     555(defun arm2-regmap-note-vstack-delta (new old)
     556  (when (< new old)
     557    (let* ((mask *arm2-gpr-locations-valid-mask*)
     558           (info *arm2-gpr-locations*))
     559    (unless (eql 0 mask)
     560      (dotimes (i 16 (setq *arm2-gpr-locations-valid-mask* mask))
     561        (when (logbitp i mask)
     562          (let* ((loc (svref info i)))
     563            (when (>= loc new)
     564              (setq mask (logandc2 mask (ash 1 i)))))))))))
     565
    540566
    541567(defun arm2-generate-pc-source-map (debug-info)
     
    819845          (! save-lisp-context-offset offset)))
    820846      (destructuring-bind (&optional zvar yvar xvar &rest stack-args) revargs
     847        (declare (ignore xvar yvar))
    821848        (let* ((nstackargs (length stack-args)))
    822849          (arm2-set-vstack (* nstackargs *arm2-target-node-size*))
     
    824851            (arm2-new-vstack-lcell :reserved *arm2-target-lcell-size* 0 nil))
    825852          (if (>= nargs 3)
    826             (push (arm2-vpush-arg-register seg ($ arm::arg_x) xvar) reg-vars))
    827           (if (>= nargs 2)
    828             (push (arm2-vpush-arg-register seg ($ arm::arg_y) yvar) reg-vars))
    829           (if (>= nargs 1)
    830             (push (arm2-vpush-arg-register seg ($ arm::arg_z) zvar) reg-vars))))
     853            (progn
     854              (! vpush-xyz)
     855              (arm2-regmap-note-store arm::arg_x *arm2-vstack*)
     856              (arm2-regmap-note-store arm::arg_y (+ *arm2-target-node-size* *arm2-vstack*))
     857              (arm2-regmap-note-store arm::arg_z (+ (* 2 *arm2-target-node-size*) *arm2-vstack*))
     858              (dotimes (i 3)
     859                (arm2-new-vstack-lcell :reserved *arm2-target-lcell-size* 0 nil))
     860              (arm2-adjust-vstack (* 3 *arm2-target-node-size*)))
     861            (if (= nargs 2)
     862              (progn
     863                (! vpush-yz)
     864                (arm2-regmap-note-store arm::arg_y *arm2-vstack*)
     865                (arm2-regmap-note-store arm::arg_z (+ *arm2-target-node-size* *arm2-vstack*))
     866                (dotimes (i 2)
     867                  (arm2-new-vstack-lcell :reserved *arm2-target-lcell-size* 0 nil))
     868                (arm2-adjust-vstack (* 2 *arm2-target-node-size*)))
     869              (if (= nargs 1)
     870                (push (arm2-vpush-arg-register seg ($ arm::arg_z) zvar) reg-vars))))))
    831871      reg-vars)))
    832872
     
    10671107
    10681108(defun arm2-set-vstack (new)
     1109  (arm2-regmap-note-vstack-delta new *arm2-vstack*)
    10691110  (setq *arm2-vstack* new))
    10701111
     
    10961137(defun arm2-stack-to-register (seg memspec reg)
    10971138  (with-arm-local-vinsn-macros (seg)
    1098     (! vframe-load reg (memspec-frame-address-offset memspec) *arm2-vstack*)))
     1139    (let* ((offset (memspec-frame-address-offset memspec))
     1140           (mask *arm2-gpr-locations-valid-mask*)
     1141           (info *arm2-gpr-locations*)
     1142           (regno (%hard-regspec-value reg)))
     1143      (unless (and (logbitp regno mask)
     1144                   (eql offset (svref info regno)))
     1145        (let* ((other (dotimes (i 16)
     1146                        (when (and (logbitp i mask)
     1147                                   (eql offset (svref info i)))
     1148                          (return i)))))
     1149          (cond (other
     1150                 (let* ((vinsn (! copy-node-gpr reg other)))
     1151                   (setq *arm2-gpr-locations-valid-mask*
     1152                         (logior mask (ash 1 regno)))
     1153                   (setf (svref info regno)
     1154                         (svref info other))
     1155                   vinsn))
     1156                (t
     1157                 (let* ((vinsn (! vframe-load reg offset *arm2-vstack*)))
     1158                   (setq *arm2-gpr-locations-valid-mask*
     1159                         (logior mask (ash 1 regno)))
     1160                   (setf (svref info regno) offset)
     1161                   vinsn))))))))
    10991162
    11001163(defun arm2-lcell-to-register (seg lcell reg)
     
    11081171(defun arm2-register-to-stack (seg reg memspec)
    11091172  (with-arm-local-vinsn-macros (seg)
    1110     (! vframe-store reg (memspec-frame-address-offset memspec) *arm2-vstack*)))
     1173    (let* ((offset (memspec-frame-address-offset memspec))
     1174           (vinsn (! vframe-store reg offset *arm2-vstack*)))
     1175      (arm2-regmap-note-store (%hard-regspec-value reg) offset)
     1176      vinsn)))
    11111177
    11121178
     
    22272293(defun arm2-restore-full-lisp-context (seg)
    22282294  (with-arm-local-vinsn-macros (seg)
    2229     (if *arm2-open-code-inline*
    2230       (! restore-full-lisp-context)
    2231       (! restore-full-lisp-context-ool))))
     2295    (! restore-full-lisp-context)))
    22322296
    22332297(defun arm2-call-symbol (seg jump-p)
     
    22422306  ; tradeoff.
    22432307  (with-arm-local-vinsn-macros (seg)
    2244     (if *arm2-open-code-inline*
    22452308      (if jump-p
    22462309        (! jump-known-symbol)
    2247         (! call-known-symbol arm::arg_z))
    2248       (if jump-p
    2249         (! jump-known-symbol-ool)
    2250         (! call-known-symbol-ool)))))
     2310        (! call-known-symbol arm::arg_z))))
    22512311
    22522312;;; Nargs = nil -> multiple-value case.
     
    23612421                           (! tail-call-fn-slide)))
    23622422                        (t
     2423                         (! restore-full-lisp-context)
    23632424                         (if symp
    2364                            (! tail-call-sym-vsp)
    2365                            (! tail-call-fn-vsp)))))))))
     2425                           (! jump-known-symbol)
     2426                           (! jump-known-function)))))))))
    23662427        ;; The general (funcall) case: we don't know (at compile-time)
    23672428        ;; for sure whether we've got a symbol or a (local, constant)
     
    26782739           (same-reg (eq (hard-regspec-value pushed-reg)
    26792740                         (hard-regspec-value popped-reg)))
    2680            (tsp-p (vinsn-attribute-p push-vinsn :tsp)))
    2681       (when (and tsp-p t)               ; vsp case is harder.
     2741           (sp-p (vinsn-attribute-p push-vinsn :sp)))
     2742      (when (and sp-p t)               ; vsp case is harder.
    26822743        (unless (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :tsp :discard)
    26832744          (let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p
     
    31083169         (! compare dest ireg jreg)
    31093170         (^ cr-bit true-p))
    3110        (with-imm-temps () ((b31-reg :natural))
    3111          (ecase cr-bit
    3112            (#. arm::arm-cond-eq
    3113             (if true-p
    3114               (! eq->bit31 b31-reg ireg jreg)
    3115               (! ne->bit31 b31-reg ireg jreg)))
    3116            (#. arm::arm-cond-lt
    3117             (if true-p
    3118               (! lt->bit31 b31-reg ireg jreg)
    3119               (! ge->bit31 b31-reg ireg jreg)))
    3120            (#. arm::arm-cond-gt
    3121             (if true-p
    3122               (! gt->bit31 b31-reg ireg jreg)
    3123               (! le->bit31 b31-reg ireg jreg))))
     3171       (with-crf-target () crf
     3172         (! compare crf ireg jreg)
    31243173         (ensuring-node-target (target dest)
    3125            (! lowbit->truth target b31-reg))
     3174           (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))))
    31263175         (^)))
    31273176      (^))))
     
    31353184         (! compare-to-nil dest ireg)
    31363185         (^ cr-bit true-p))
    3137        (with-imm-temps () ((b31-reg :natural))
    3138          (ecase cr-bit
    3139            (#. arm::arm-cond-eq
    3140             (if true-p
    3141               (! eqnil->bit31 b31-reg ireg)
    3142               (! nenil->bit31 b31-reg ireg))))
     3186       (with-crf-target () crf
     3187         (! compare-to-nil crf ireg)
    31433188         (ensuring-node-target (target dest)
    3144            (! lowbit->truth target b31-reg))
     3189           (! cond->boolean target (if true-p cr-bit (logxor cr-bit 1))))
    31453190         (^)))
    31463191      (^))))
     
    32193264    (prog1
    32203265      (! vpush-register src)
     3266      (arm2-regmap-note-store src *arm2-vstack*)
    32213267      (arm2-new-vstack-lcell (or why :node) *arm2-target-lcell-size* (or attr 0) info)
    32223268      (arm2-adjust-vstack *arm2-target-node-size*))))
     
    48094855         (vp (vinsn-variable-parts vinsn))
    48104856         (nvp (vinsn-template-nvp template))
    4811          (unique-labels ()))
     4857         (unique-labels ())
     4858         (operand-insert-functions arm::*arm-vinsn-insert-functions*))
    48124859    (declare (fixnum nvp))
    48134860    (dotimes (i nvp)
     
    48204867        (arm::make-lap-label unique)))
    48214868    (labels ((parse-operand-form (valform)
     4869               ;(break "valform = ~s" valform)
    48224870               (cond ((typep valform 'keyword)
    48234871                      (or (assq valform unique-labels)
     
    48354883                            (setq tail (cdr (rplaca tail (parse-operand-form op)))))))))
    48364884             (expand-insn-form (f)
    4837                (let* ((operands (cdr f))
    4838                       (head (make-list (length operands)))
    4839                       (tail head))
    4840                  (declare (dynamic-extent head)
    4841                           (cons head tail))
    4842                  (dolist (op operands)
    4843                    (rplaca tail (parse-operand-form op))
    4844                    (setq tail (cdr tail)))
    4845                  (arm-emit-lap-instruction (svref arm::*arm-opcodes* (car f))
    4846                                            head)))
     4885               (case (car f)
     4886                 (:code (setq current (svref sections 0)))
     4887                 (:data (setq current (svref sections 1)))
     4888                 (:word
     4889                  (let* ((insn (arm::make-lap-instruction nil)))
     4890                    (setf (arm::lap-instruction-opcode insn)
     4891                          (parse-operand-form (cadr f)))
     4892                    (append-dll-node insn current)))
     4893                 (t
     4894                  (let* ((insn (arm::make-lap-instruction nil))
     4895                         (operands (cdr f)))
     4896                    (setf (arm::lap-instruction-opcode insn) (car f))
     4897                    (dolist (op operands (append-dll-node insn current))
     4898                      (let* ((insert-function (svref operand-insert-functions (car op))))
     4899                        (funcall insert-function insn (parse-operand-form (cdr op)))))))))
    48474900             (eval-predicate (f)
    48484901               (case (car f)
     
    48784931      (setf (vinsn-variable-parts vinsn) nil)
    48794932      (when vp
    4880         (free-varparts-vector vp)))))
     4933        (free-varparts-vector vp))
     4934      current)))
    48814935
    48824936
     
    49645018           (num-req (length req))
    49655019           (num-opt (length (%car opt)))
    4966            (no-regs nil)
    49675020           (arg-regs nil)
    49685021           optsupvloc
     
    49715024      (declare (type (unsigned-byte 16) num-req num-opt num-inh))
    49725025      (with-arm-p2-declarations p2decls
    4973         (setq *arm2-inhibit-register-allocation*
    4974               (setq no-regs (%ilogbitp $fbitnoregs fbits)))
    4975 
     5026        ;; Need to do this for effect here.
     5027        (nx2-allocate-global-registers *arm2-fcells* *arm2-vcells* nil nil nil)
    49765028        (@ (backend-get-next-label)) ; generic self-reference label, should be label #1
    49775029        (when keys ;; Ensure keyvect is the first immediate
     
    50015053                (unless (or rest keys)
    50025054                  (! check-max-nargs (+ num-fixed num-opt)))
    5003                 ;; Going to have to call one or more subprims.  First save
    5004                 ;; the LR in LOC-PC.
    5005                 (! save-lr)
     5055                (! save-lisp-context-variable)
    50065056                ;; If there were &optional args, initialize their values
    50075057                ;; to NIL.  All of the argregs get vpushed as a result of this.
     
    50745124                       (nbytes-vpushed (* nwords-vpushed *arm2-target-node-size*)))
    50755125                  (declare (fixnum nwords-vpushed nbytes-vpushed))
    5076                   (unless (or lexprp keys)
    5077                     (if *arm2-open-code-inline*
    5078                       (! save-lisp-context-offset nbytes-vpushed)
    5079                       (! save-lisp-context-offset-ool nbytes-vpushed)))
     5126
    50805127                  (arm2-set-vstack nbytes-vpushed)
    50815128                  (setq optsupvloc (- *arm2-vstack* (* num-opt *arm2-target-node-size*)))))))
Note: See TracChangeset for help on using the changeset viewer.