Changeset 14922


Ignore:
Timestamp:
Aug 1, 2011, 5:29:56 AM (13 years ago)
Author:
Gary Byers
Message:

In ARM disassembler, print apparent fixnum-valued operands using
QUOTE if there are GPR operands and all such operands are node regs.
Use ~S when printing operands in some other cases.

In ARM backend, revive some changes that were backed out of a few
days ago and implement some similar things: extend the register-
tracking mechanism to deal with constants (t/nil/fixnums/immediates),
try to better integrate the register-tracking stuff with the things
that do "soft" register targeting (and deal with conflicts that may
be introduced as a result.) Skip some function-call overhead on
some self-calls.

If we aren't bounds-checking and have a known-fixnum index in ARM2-VSET,
don't bother to load that index into a register.

The lisp builds itself and passes all tests with these changes in effect;
some of the issues in getting to that point are subtle so this should
be viewed with at least some suspicion.

Location:
trunk/source/compiler/ARM
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • trunk/source/compiler/ARM/arm-disassemble.lisp

    r14897 r14922  
    440440                (return)
    441441                (format-spname labeled stream))))
    442           (let* ((name (adi-mnemonic info)))
     442          (let* ((name (adi-mnemonic info))
     443                 (use-fixnum-syntax nil))           
    443444            (when name
    444445              (let* ((condition-name (or (adi-condition-name info) "")))
    445446                (format stream "~&  (~a~a" name condition-name))
    446               (labels ((format-operand (operand)
     447              (let* ((ngpr 0)
     448                     (nnode 0))
     449                (declare (fixnum ngpr nnode))
     450                (dolist (op (adi-operands info))
     451                  (when (and (consp op) (eq (car op) :gpr))
     452                    (incf ngpr)
     453                    (when (logbitp (cadr op) arm-node-regs)
     454                      (incf nnode))))
     455                (unless (zerop ngpr)
     456                  (setq use-fixnum-syntax (eql nnode ngpr))))
     457              (labels ((format-operand (operand &optional toplevel)
    447458                         (write-char #\space stream)
    448459                         (if (atom operand)
    … …  
    473484                              (format-spname (cadr operand) stream))
    474485                             (:$
    475                               (if (eql (cadr operand) arm::nil-value)
    476                                 (format stream "'nil")
    477                                 (progn
    478                                   (format stream "(:$")
    479                                   (format-operand (cadr operand))
    480                                   (write-char #\) stream))))
     486                              (let* ((val (cadr operand)))
     487                                (cond ((eql val arm::nil-value)
     488                                       (format stream "'nil"))
     489                                      ((and toplevel
     490                                           use-fixnum-syntax
     491                                           (typep val 'integer)
     492                                           (not (logtest arm::fixnummask val)))
     493                                       (let* ((unboxed (ash val (- arm::fixnumshift))))
     494                                         (if (> (abs unboxed) 100)
     495                                           (format stream "'#x~x" unboxed)
     496                                           (format stream "'~d" unboxed))))
     497                                      (t
     498                                       (progn
     499                                         (format stream "(:$")
     500                                         (format-operand val)
     501                                         (write-char #\) stream))))))
    481502                             (:? (format stream "(:? ~a)" (cadr operand)))
    482503                             (:gpr (format stream "~a" (svref *arm-gpr-names* (cadr operand))))
    … …  
    497518                              (write-char #\) stream))))))
    498519                (dolist (op (adi-operands info))
    499                   (format-operand op))
     520                  (format-operand op t))
    500521                (write-char #\) stream)
    501522                (when (eql (incf pc-counter) 4)

  • trunk/source/compiler/ARM/arm2.lisp

    r14909 r14922  
    151151
    152152(defvar *arm2-entry-label* nil)
    153 (defvar *arm2-tail-label* nil)
    154 (defvar *arm2-tail-vsp* nil)
    155 (defvar *arm2-tail-nargs* nil)
     153(defvar *arm2-fixed-args-label* nil)
     154(defvar *arm2-fixed-args-tail-label* nil)
     155(defvar *arm2-fixed-nargs* nil)
    156156(defvar *arm2-tail-allow* t)
    157157(defvar *arm2-reckless* nil)
    … …  
    160160(defvar *arm2-trust-declarations* nil)
    161161(defvar *arm2-entry-vstack* nil)
    162 (defvar *arm2-fixed-nargs* nil)
    163162(defvar *arm2-need-nargs* t)
    164163
    … …  
    171170(defvar *arm2-gpr-locations* nil)
    172171(defvar *arm2-gpr-locations-valid-mask* 0)
     172(defvar *arm2-gpr-constants* nil)
     173(defvar *arm2-gpr-constants-valid-mask* 0)
     174
    173175
    174176
    … …  
    256258      (or (= depth *arm2-vstack*)
    257259          (warn "~a: lcell depth = ~d, vstack = ~d" context depth *arm2-vstack*)))))
     260
     261(defun arm2-gprs-containing-constant (c)
     262  (let* ((in *arm2-gpr-constants-valid-mask*)
     263         (vals *arm2-gpr-constants*)
     264         (out 0))
     265    (declare (fixnum in out) (simple-vector vals))
     266    (dotimes (i 16 out)
     267      (declare (type (mod 16) i))
     268      (when (and (logbitp i in)
     269                 (eql c (svref vals i)))
     270        (setq out (logior out (ash 1 i)))))))
     271
    258272
    259273(defun arm2-do-lexical-reference (seg vreg ea)
    … …  
    400414           (*backend-immediates* (arm2-make-stack 64  target::subtag-simple-vector))
    401415           (*arm2-entry-label* nil)
    402            (*arm2-tail-label* nil)
    403            (*arm2-tail-vsp* nil)
    404            (*arm2-tail-nargs* nil)
     416           (*arm2-fixed-args-label* nil)
     417           (*arm2-fixed-args-tail-label*)
     418           (*arm2-fixed-nargs* nil)
    405419           (*arm2-inhibit-register-allocation* nil)
    406420           (*arm2-tail-allow* t)
    … …  
    410424           (*arm2-trust-declarations* t)
    411425           (*arm2-entry-vstack* nil)
    412            (*arm2-fixed-nargs* nil)
    413426           (*arm2-need-nargs* t)
    414427           (fname (afunc-name afunc))
    … …  
    419432           (*arm2-emitted-source-notes* '())
    420433           (*arm2-gpr-locations-valid-mask* 0)
    421            (*arm2-gpr-locations* (make-array 16 :initial-element nil)))
    422       (declare (dynamic-extent *arm2-gpr-locations*))
     434           (*arm2-gpr-locations* (make-array 16 :initial-element nil))
     435           (*arm2-gpr-constants-valid-mask* 0)
     436           (*arm2-gpr-constants*(make-array 16 :initial-element nil)))
     437      (declare (dynamic-extent *arm2-gpr-locations* *arm2-gpr-constants*))
    423438      (set-fill-pointer
    424439       *backend-labels*
    … …  
    515530
    516531(defun arm2-invalidate-regmap ()
    517   (setq *arm2-gpr-locations-valid-mask* 0))
     532  (setq *arm2-gpr-locations-valid-mask* 0
     533        *arm2-gpr-constants-valid-mask* 0))
    518534
    519535(defun arm2-update-regmap (vinsn)
    520536  (if (vinsn-attribute-p vinsn :call)
    521537    (arm2-invalidate-regmap)
    522     (setq *arm2-gpr-locations-valid-mask* (logandc2 *arm2-gpr-locations-valid-mask* (vinsn-gprs-set vinsn))))
    523   vinsn)
     538    (let* ((clobbered-regs (vinsn-gprs-set vinsn)))
     539      (setq *arm2-gpr-locations-valid-mask* (logandc2 *arm2-gpr-locations-valid-mask* clobbered-regs)
     540            *arm2-gpr-constants-valid-mask* (logandc2 *arm2-gpr-constants-valid-mask* clobbered-regs))))
     541    vinsn)
    524542
    525543(defun arm2-regmap-note-store (gpr loc)
    … …  
    570588      (setf (svref to i) (copy-list (svref from i))))))
    571589
    572 (defmacro with-arm2-saved-regmap ((mask map) &body body)
     590(defun arm2-copy-constmap (mask from to)
     591  (dotimes (i 16)
     592    (when (logbitp i mask)
     593      (setf (svref to i) (svref from i)))))
     594   
     595
     596(defmacro with-arm2-saved-regmaps ((mask constmask map constmap) &body body)
    573597  `(let* ((,mask *arm2-gpr-locations-valid-mask*)
    574           (,map (make-array 16 :initial-element nil)))
    575     (declare (dynamic-extent ,map))
     598          (,constmask *arm2-gpr-constants-valid-mask*)
     599          (,map (make-array 16 :initial-element nil))
     600          (,constmap (make-array 16)))
     601    (declare (dynamic-extent ,map ,constmap))
    576602    (arm2-copy-regmap ,mask *arm2-gpr-locations* ,map)
     603    (arm2-copy-constmap ,constmap *arm2-gpr-constants* ,constmap)
    577604    ,@body))
    578605
    … …  
    853880           (reg-vars ()))
    854881      (declare (type (unsigned-byte 16) nargs))
     882      (when (and
     883             (<= nargs $numarmargregs)
     884             (not (some #'null revargs)))
     885        (setq *arm2-fixed-nargs* nargs))
    855886      (if (<= nargs $numarmargregs)       ; caller didn't vpush anything
    856887        (! save-lisp-context-vsp)
    … …  
    858889          (declare (fixnum offset))
    859890          (! save-lisp-context-offset offset)))
     891      (when *arm2-fixed-args-label*
     892        (@ (setq *arm2-fixed-args-tail-label* (backend-get-next-label))))
    860893      (destructuring-bind (&optional zvar yvar xvar &rest stack-args) revargs
    861894        (declare (ignore xvar yvar))
    … …  
    11061139    (if (arm2-for-value-p vreg)
    11071140      (ensuring-node-target (target vreg)
    1108         (! load-nil target)))
     1141        (let* ((regval (hard-regspec-value target))
     1142               (regs (arm2-gprs-containing-constant nil)))
     1143          (unless (logbitp regval regs)
     1144            (! load-nil target)
     1145            (setf *arm2-gpr-constants-valid-mask*
     1146                  (logior *arm2-gpr-constants-valid-mask* (ash 1 regval))
     1147                  (svref *arm2-gpr-constants* regval) nil)))))
    11091148    (arm2-branch seg (arm2-cd-false xfer) vreg)))
    11101149
    … …  
    11131152    (if (arm2-for-value-p vreg)
    11141153      (ensuring-node-target (target vreg)
    1115         (! load-t target)))
     1154        (let* ((regval (hard-regspec-value target))
     1155               (regs (arm2-gprs-containing-constant t)))
     1156          (declare (fixnum regval regs))
     1157          (unless (logbitp regval regs)
     1158            (if (zerop regs)
     1159              (! load-t target)
     1160              (let* ((r (1- (integer-length regs))))
     1161                (! copy-node-gpr target r)))
     1162            (setf *arm2-gpr-constants-valid-mask*
     1163                  (logior *arm2-gpr-constants-valid-mask* (ash 1 regval))
     1164                  (svref *arm2-gpr-constants* regval) t)))))
    11161165    (arm2-branch seg (arm2-cd-true xfer) vreg)))
    11171166
    … …  
    11651214 
    11661215
    1167 
     1216(defun arm2-reg-for-form (form hint)
     1217  (when (node-reg-p hint)
     1218    (let* ((var (arm2-lexical-reference-p form)))
     1219      (if var
     1220        (let* ((ea (var-ea var)))
     1221          (when (and (memory-spec-p ea)
     1222                     (not (addrspec-vcell-p ea)))
     1223            (let* ((offset (memspec-frame-address-offset ea))
     1224                   (mask *arm2-gpr-locations-valid-mask*)
     1225                   (info *arm2-gpr-locations*))
     1226              (declare (fixnum mask) (simple-vector info))
     1227              (dotimes (reg 16)
     1228                (when (and (logbitp reg mask)
     1229                           (memq offset (svref info reg)))
     1230                  (return reg))))))
     1231        (multiple-value-bind (value constantp) (acode-constant-p form)
     1232          (when constantp
     1233            (let* ((regs (arm2-gprs-containing-constant value))
     1234                   (regno (hard-regspec-value hint)))
     1235              (if (logbitp regno regs)
     1236                hint
     1237                (unless (eql 0 regs)
     1238                  (1- (integer-length regs)))))))))))
     1239                 
     1240           
     1241         
    11681242
    11691243(defun arm2-stack-to-register (seg memspec reg)
    … …  
    12501324                    hard-reg-class-gpr-mode-u32))
    12511325          (arm2-lri seg vreg form)
    1252           (ensuring-node-target
    1253            (target vreg)
    1254            (if (characterp form)
    1255              (! load-character-constant target (char-code form))
    1256              (arm2-store-immediate seg form target)))))
    1257       (if (and (listp form) *load-time-eval-token* (eq (car form) *load-time-eval-token*))
    1258         (arm2-store-immediate seg form ($ arm::temp0))))
     1326          (ensuring-node-target (target vreg)
     1327            (let* ((regno (hard-regspec-value target))
     1328                   (regs (arm2-gprs-containing-constant form)))
     1329              (unless (logbitp regno regs)
     1330                (if (eql 0 regs)
     1331                  (if (characterp form)
     1332                    (! load-character-constant target (char-code form))
     1333                    (arm2-store-immediate seg form target))
     1334                  (let* ((r (1- (integer-length regs))))
     1335                    (! copy-node-gpr target r)))
     1336                (setf *arm2-gpr-constants-valid-mask*
     1337                      (logior *arm2-gpr-constants-valid-mask*
     1338                              (ash 1 regno))
     1339                      (svref *arm2-gpr-constants* regno) form))))))
     1340        (if (and (listp form) *load-time-eval-token* (eq (car form) *load-time-eval-token*))
     1341          (arm2-store-immediate seg form ($ arm::temp0))))
    12591342    (^)))
    12601343
    … …  
    21882271                                              value result-reg))
    21892272              (t
    2190                (multiple-value-setq (src unscaled-idx result-reg)
    2191                  (arm2-three-untargeted-reg-forms seg
    2192                                               vector src
    2193                                               index unscaled-idx
    2194                                               value (arm2-target-reg-for-aset vreg type-keyword)))))
     2273               (if (and (not safe) index-known-fixnum)
     2274                 (multiple-value-setq (src result-reg unscaled-idx)
     2275                   (arm2-two-untargeted-reg-forms seg
     2276                                                  vector src
     2277                                                  value (arm2-target-reg-for-aset vreg type-keyword)))
     2278                 (multiple-value-setq (src unscaled-idx result-reg)
     2279                   (arm2-three-untargeted-reg-forms seg
     2280                                                    vector src
     2281                                                    index unscaled-idx
     2282                                                    value (arm2-target-reg-for-aset vreg type-keyword))))))
    21952283        (when safe
    21962284          (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)
    … …  
    23692457           (callable (or symp lfunp label-p))
    23702458           (destreg (if symp ($ arm::fname) (if lfunp ($ arm::nfn) (unless label-p ($ arm::nfn)))))
    2371            (alternate-tail-call
    2372             (and tail-p label-p *arm2-tail-label* (eql nargs *arm2-tail-nargs*) (not spread-p)))
    2373            )
     2459           (known-fixed-nargs nil)
     2460           (label (when label-p
     2461                    (if (and *arm2-fixed-args-label*
     2462                             (eql nargs *arm2-fixed-nargs*)
     2463                             (not spread-p)
     2464                             (not (arm2-mvpass-p xfer)))
     2465                      (progn
     2466                        (setq known-fixed-nargs t)
     2467                        (if tail-p
     2468                          *arm2-fixed-args-tail-label*
     2469                          *arm2-fixed-args-label*))
     2470                      1))))
    23742471      (when expression-p
    23752472        ;;Have to do this before spread args, since might be vsp-relative.
    … …  
    23932490            (! spread-list)))
    23942491        (if nargs
    2395           (unless alternate-tail-call (arm2-set-nargs seg nargs))
     2492          (unless known-fixed-nargs (arm2-set-nargs seg nargs))
    23962493          (! pop-argument-registers)))
    23972494      (if callable
    … …  
    24112508                (progn
    24122509                  (arm2-copy-register seg ($ arm::nfn) ($  arm::fn))
    2413                   (! call-label (aref *backend-labels* 1)))
     2510                  (! call-label (aref *backend-labels* label)))
    24142511                (progn
    24152512                  (if a-reg
    … …  
    24192516                    (arm2-call-symbol seg nil)
    24202517                    (! call-known-function))))))
    2421           (if alternate-tail-call
    2422             (progn
    2423               (arm2-unwind-stack seg xfer 0 0 *arm2-tail-vsp*)
    2424               (! jump (aref *backend-labels* *arm2-tail-label*)))
    2425             (progn
    2426               (arm2-unwind-stack seg xfer 0 0 #x7fffff)
    2427               (if (and (not spread-p) nargs (%i<= nargs $numarmargregs))
    2428                 (progn
    2429                   (if label-p
    2430                     (arm2-copy-register seg arm::nfn arm::fn))
    2431                   (unless (or label-p a-reg) (arm2-store-immediate seg func destreg))
    2432                   (arm2-restore-full-lisp-context seg)
    2433                   (if label-p
    2434                     (! jump (aref *backend-labels* 1))
    2435                     (progn
    2436                       (if symp
    2437                         (arm2-call-symbol seg t)
    2438                         (! jump-known-function)))))
    2439                 (progn
    2440                   (if label-p
    2441                     (arm2-copy-register seg arm::nfn arm::fn)
    2442                     (unless a-reg (arm2-store-immediate seg func destreg)))
    2443                   (cond ((or spread-p (null nargs))
    2444                          (if symp
    2445                            (! tail-call-sym-gen)
    2446                            (! tail-call-fn-gen)))
    2447                         ((%i> nargs $numarmargregs)
    2448                          (if symp
    2449                            (! tail-call-sym-slide)
    2450                            (! tail-call-fn-slide)))
    2451                         (t
    2452                          (! restore-full-lisp-context)
    2453                          (if symp
    2454                            (! jump-known-symbol)
    2455                            (! jump-known-function)))))))))
     2518          (progn
     2519            (arm2-unwind-stack seg xfer 0 0 #x7fffff)
     2520            (if (and (not spread-p) nargs (%i<= nargs $numarmargregs))
     2521              (progn
     2522                (if label-p
     2523                  (unless known-fixed-nargs
     2524                    (arm2-copy-register seg arm::nfn arm::fn)))
     2525                (unless (or label-p a-reg) (arm2-store-immediate seg func destreg))
     2526                (unless known-fixed-nargs
     2527                  (arm2-restore-full-lisp-context seg))
     2528                (if label-p
     2529                  (! jump (aref *backend-labels* label))
     2530                  (progn
     2531                    (if symp
     2532                      (arm2-call-symbol seg t)
     2533                      (! jump-known-function)))))
     2534              (progn
     2535                (if label-p
     2536                  (arm2-copy-register seg arm::nfn arm::fn)
     2537                  (unless a-reg (arm2-store-immediate seg func destreg)))
     2538                (cond ((or spread-p (null nargs))
     2539                       (if symp
     2540                         (! tail-call-sym-gen)
     2541                         (! tail-call-fn-gen)))
     2542                      ((%i> nargs $numarmargregs)
     2543                       (if symp
     2544                         (! tail-call-sym-slide)
     2545                         (! tail-call-fn-slide)))
     2546                      (t
     2547                       (! restore-full-lisp-context)
     2548                       (if symp
     2549                         (! jump-known-symbol)
     2550                         (! jump-known-function))))))))
    24562551        ;; The general (funcall) case: we don't know (at compile-time)
    24572552        ;; for sure whether we've got a symbol or a (local, constant)
    … …  
    26962791  (arm2-one-lreg-form seg form (if (typep reg 'lreg) reg (make-unwired-lreg reg))))
    26972792
     2793(defun same-arm-reg-p (x y)
     2794  (and (eq (hard-regspec-value x) (hard-regspec-value y))
     2795       (let* ((class (hard-regspec-class x)))
     2796         (and (eq class (hard-regspec-class y))
     2797              (or (not (eql class hard-reg-class-fpr))
     2798                  (eq (%get-regspec-mode x)
     2799                      (%get-regspec-mode y)))))))
     2800
    26982801(defun arm2-one-untargeted-reg-form (seg form suggested)
    2699   (with-arm-local-vinsn-macros (seg)
    2700     (let* ((gpr-p (= (hard-regspec-class suggested) hard-reg-class-gpr))
    2701            (node-p (if gpr-p (= (get-regspec-mode suggested) hard-reg-class-gpr-mode-node))))
    2702       (if node-p
    2703         (let* ((ref (arm2-lexical-reference-ea form))
    2704                (reg (backend-ea-physical-reg ref hard-reg-class-gpr)))
    2705           (if reg
    2706             ref
    2707             (if (nx-null form)
    2708               (progn
    2709                 (! load-nil suggested)
    2710                 suggested)
    2711               (if (and (acode-p form)
    2712                        (eq (acode-operator form) (%nx1-operator immediate))
    2713                        (setq reg (arm2-register-constant-p (cadr form))))
    2714                 reg
    2715                 (if (and (acode-p form)
    2716                          (eq (acode-operator form) (%nx1-operator %current-tcr)))
    2717                   arm::rcontext
    2718                   (arm2-one-untargeted-lreg-form seg form suggested))))))
    2719         (arm2-one-untargeted-lreg-form seg form suggested)))))
     2802  (or (arm2-reg-for-form form suggested)
     2803      (with-arm-local-vinsn-macros (seg)
     2804        (let* ((gpr-p (= (hard-regspec-class suggested) hard-reg-class-gpr))
     2805               (node-p (if gpr-p (= (get-regspec-mode suggested) hard-reg-class-gpr-mode-node))))
     2806          (if node-p
     2807            (if (and (acode-p form)
     2808                     (eq (acode-operator form) (%nx1-operator %current-tcr)))
     2809              arm::rcontext
     2810              (arm2-one-untargeted-lreg-form seg form suggested))
     2811            (arm2-one-untargeted-lreg-form seg form suggested))))))
    27202812             
    27212813
    … …  
    28312923
    28322924(defun arm2-two-untargeted-reg-forms (seg aform areg bform breg)
    2833   (with-arm-local-vinsn-macros (seg)
    2834     (let* ((avar (arm2-lexical-reference-p aform))
    2835            (adest areg)
    2836            (bdest breg)
    2837            (atriv (and (arm2-trivial-p bform) (nx2-node-gpr-p breg)))
    2838            (aconst (and (not atriv) (or (arm-side-effect-free-form-p aform)
    2839                                         (if avar (arm2-var-not-set-by-form-p avar bform)))))
    2840            (apushed (not (or atriv aconst))))
    2841       (progn
    2842         (unless aconst
    2843           (if atriv
    2844             (setq adest (arm2-one-untargeted-reg-form seg aform areg))
    2845             (setq apushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg aform (arm2-acc-reg-for areg))))))
    2846         (setq bdest (arm2-one-untargeted-reg-form seg bform breg))
    2847         (if aconst
    2848           (setq adest (arm2-one-untargeted-reg-form seg aform areg))
    2849           (if apushed
    2850             (arm2-elide-pushes seg apushed (arm2-pop-register seg areg)))))
    2851       (values adest bdest))))
     2925  (let* ((aalready (arm2-reg-for-form aform areg))
     2926         (balready (arm2-reg-for-form bform breg)))
     2927    (if (and aalready balready)
     2928      (values aalready balready)
     2929      (with-arm-local-vinsn-macros (seg)
     2930        (let* ((avar (arm2-lexical-reference-p aform))
     2931               (adest areg)
     2932               (bdest breg)
     2933               (atriv (and (arm2-trivial-p bform) (nx2-node-gpr-p breg)))
     2934               (aconst (and (not atriv) (or (arm-side-effect-free-form-p aform)
     2935                                            (if avar (arm2-var-not-set-by-form-p avar bform)))))
     2936               (apushed (not (or atriv aconst))))
     2937          (progn
     2938            (unless aconst
     2939              (if atriv
     2940                (progn
     2941                  (setq adest (arm2-one-untargeted-reg-form seg aform areg))
     2942                  (when (same-arm-reg-p adest breg)
     2943                    (setq breg areg)))
     2944                (setq apushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg aform (arm2-acc-reg-for areg))))))
     2945            (if (setq bdest (arm2-reg-for-form bform breg))
     2946              (when (same-arm-reg-p bdest areg)
     2947                (setq areg breg))
     2948              (setq bdest (arm2-one-untargeted-reg-form seg bform breg)))
     2949            (if aconst
     2950              (setq adest (arm2-one-untargeted-reg-form seg aform areg))
     2951              (if apushed
     2952                (arm2-elide-pushes seg apushed (arm2-pop-register seg areg)))))
     2953          (values adest bdest))))))
    28522954
    28532955
    … …  
    29923094      (if (and aform (not aconst))
    29933095        (if atriv
    2994           (setq adest (arm2-one-untargeted-reg-form seg aform ($ areg)))
     3096          (progn
     3097            (setq adest (arm2-one-untargeted-reg-form seg aform ($ areg)))
     3098            (when (same-arm-reg-p adest breg)
     3099              (setq breg areg))
     3100            (when (same-arm-reg-p adest creg)
     3101              (setq creg areg)))
    29953102          (setq apushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg aform (arm2-acc-reg-for areg))))))
    29963103      (if (and bform (not bconst))
    29973104        (if btriv
    2998           (setq bdest (arm2-one-untargeted-reg-form seg bform ($ breg)))
     3105          (progn
     3106            (setq bdest (arm2-one-untargeted-reg-form seg bform ($ breg)))
     3107            (when (same-arm-reg-p bdest creg)
     3108              (setq creg breg))
     3109            (when (same-arm-reg-p bdest areg)
     3110              (setq areg breg)))
    29993111          (setq bpushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg bform (arm2-acc-reg-for breg))))))
    30003112      (setq cdest (arm2-one-untargeted-reg-form seg cform creg))
     3113      (when (same-arm-reg-p cdest areg)
     3114        (setq areg creg))
     3115      (when (same-arm-reg-p cdest breg)
     3116        (setq breg creg))
    30013117      (unless btriv
    30023118        (if bconst
    … …  
    30563172    (if (and aform (not aconst))
    30573173      (if atriv
    3058         (setq adest (arm2-one-targeted-reg-form seg aform areg))
     3174        (progn
     3175          (setq adest (arm2-one-targeted-reg-form seg aform areg))
     3176          (when (same-arm-reg-p adest breg)
     3177            (setq breg areg))
     3178          (when (same-arm-reg-p adest creg)
     3179            (setq creg areg))
     3180          (when (same-arm-reg-p adest dreg)
     3181            (setq dreg areg)))
    30593182        (setq apushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg aform (arm2-acc-reg-for areg))))))
    30603183    (if (and bform (not bconst))
    30613184      (if btriv
    3062         (setq bdest (arm2-one-untargeted-reg-form seg bform breg))
     3185        (progn
     3186          (setq bdest (arm2-one-untargeted-reg-form seg bform breg))
     3187          (when (same-arm-reg-p bdest creg)
     3188            (setq creg breg))
     3189          (when (same-arm-reg-p bdest dreg)
     3190            (setq dreg breg)))
    30633191        (setq bpushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg bform (arm2-acc-reg-for breg))))))
    30643192    (if (and cform (not cconst))
    30653193      (if ctriv
    3066         (setq cdest (arm2-one-untargeted-reg-form seg cform creg))
     3194        (progn
     3195          (setq cdest (arm2-one-untargeted-reg-form seg cform creg))
     3196          (when (same-arm-reg-p cdest dreg)
     3197            (setq dreg creg)))
    30673198        (setq cpushed (arm2-push-register seg (arm2-one-untargeted-reg-form seg cform (arm2-acc-reg-for creg))))))
    30683199    (setq ddest (arm2-one-untargeted-reg-form seg dform dreg))
     3200    (when (same-arm-reg-p ddest areg)
     3201      (setq areg dreg))
     3202    (when (same-arm-reg-p ddest breg)
     3203      (setq breg dreg))
     3204    (when (same-arm-reg-p ddest creg)
     3205      (setq creg dreg))
    30693206    (unless ctriv
    30703207      (if cconst
    … …  
    50765213               (rev-opt (reverse (car opt))))
    50775214          (if (not (or opt rest keys))
    5078             (setq arg-regs (arm2-req-nargs-entry seg rev-fixed))
     5215            (progn
     5216              (setq arg-regs (arm2-req-nargs-entry seg rev-fixed)))
    50795217            (if (and (not (or hardopt rest keys))
    50805218                     (<= num-opt $numarmargregs))
    … …  
    51695307          ;; to worry about.
    51705308
    5171           (when (and nil
    5172                      (not (or opt rest keys))
    5173                      (<= num-fixed $numarmargregs)
    5174                      (not (some #'null arg-regs)))
    5175             (setq *arm2-tail-vsp* *arm2-vstack*
    5176                   *arm2-tail-nargs* num-fixed)
    5177             (@ (setq *arm2-tail-label* (backend-get-next-label))))
     5309
    51785310          (when method-var
    51795311            (arm2-seq-bind-var seg method-var arm::next-method-context))
    … …  
    58245956          (progn
    58255957            (ensuring-node-target (target vreg)
    5826               (arm2-absolute-natural seg target nil (ash value *arm2-target-fixnum-shift*)))
     5958              (let* ((boxed (ash value *arm2-target-fixnum-shift*))
     5959                     (regval (hard-regspec-value target))
     5960                     (regs (arm2-gprs-containing-constant value))
     5961                     (small (or (arm::encode-arm-immediate boxed)
     5962                                (arm::encode-arm-immediate (lognot boxed)))))
     5963                (unless (logbitp regval regs)
     5964                  (if (or small (eql 0 regs))
     5965                    (arm2-absolute-natural seg target nil boxed)
     5966                    (let* ((r (1- (integer-length regs))))
     5967                      (! copy-node-gpr target r)))
     5968                  (setf *arm2-gpr-constants-valid-mask*
     5969                        (logior *arm2-gpr-constants-valid-mask*
     5970                                (ash 1 regval))
     5971                        (svref *arm2-gpr-constants* regval) value))))
    58275972            (^)))))))
    58285973
    … …  
    59966141
    59976142
     6143(defun arm2-generate-casejump (seg vreg xfer ranges trueforms var otherwise)
     6144  (declare (ignorable trueforms var otherwise))
     6145  (with-arm-local-vinsn-macros (seg vreg xfer)
     6146    (unless (arm2-mvpass-p xfer)
     6147      (when ranges
     6148        (let* ((min (caar ranges))
     6149               (max min)
     6150               (count 0)
     6151               (all ()))
     6152          (declare (fixnum min max count))
     6153          (when ; determine min,max, count; punt on duplicate keys
     6154              (dolist (range ranges t)
     6155                (let* ((info (cons (backend-get-next-label) (pop trueforms))))
     6156                  (unless (dolist (val range t)
     6157                            (declare (fixnum val))
     6158                            (when (assoc val all)
     6159                              (return nil))
     6160                            (push (cons val info) all)
     6161                            (if (< val min)
     6162                              (setq min val)
     6163                              (if (> val max)
     6164                                (setq max val)))
     6165                            (incf count))
     6166                    (return nil))))
     6167                (let* ((span (1+ (- max min))))
     6168                  (declare (fixnum span))
     6169                  (when (and (> count 4)
     6170                             (> count (the fixnum (- span (the fixnum (ash span -2))))))
     6171                    (let* ((defaultlabel (backend-get-next-label))
     6172                           (endlabel (backend-get-next-label))
     6173                           (reg ($ arm::arg_z)))
     6174                      (arm2-use-operator (%nx1-operator lexical-reference)
     6175                                         seg reg nil var)
     6176                      (! cjmp reg (ash min arm::fixnumshift) (ash (- max min) arm::fixnumshift)  (aref *backend-labels* defaultlabel))
     6177                      (do* ((val min (1+ val)))
     6178                           ((> val max))
     6179                        (declare (fixnum val))
     6180                        (let* ((info (assoc val all)))
     6181                          (! non-barrier-jump (aref *backend-labels* (if info (cadr info) defaultlabel)))))
     6182                      (let* ((target (arm2-cd-merge xfer endlabel)))
     6183                        (dolist (case (nreverse all))
     6184                          (let* ((lab (cadr case))
     6185                                 (form (cddr case)))
     6186                            (@ lab)
     6187                            (arm2-form seg vreg target form)))
     6188                        (@ defaultlabel)
     6189                        (arm2-form seg vreg target otherwise)
     6190                        (@ endlabel)
     6191                        (when (arm2-mvpass-p xfer)
     6192                          (^))
     6193                        t))))))))))
     6194                       
     6195
    59986196(defarm2 arm2-if if (seg vreg xfer testform true false &aux test-val)
    59996197  (if (setq test-val (nx2-constant-form-value (acode-unwrapped-form-value testform)))
    60006198    (arm2-form seg vreg xfer (if (nx-null test-val) false true))
    6001     (let* ((cstack *arm2-cstack*)
    6002            (vstack *arm2-vstack*)
    6003            (top-lcell *arm2-top-vstack-lcell*)
    6004            (entry-stack (arm2-encode-stack))
    6005            (true-stack nil)
    6006            (false-stack nil)
    6007            (true-cleanup-label nil)
    6008            (same-stack-effects nil)
    6009            (true-is-goto (arm2-go-label true))
    6010            (false-is-goto (and (not true-is-goto) (arm2-go-label false)))
    6011            (endlabel (backend-get-next-label))
    6012            (falselabel (backend-get-next-label))
    6013            (need-else (unless false-is-goto (or (not (nx-null false)) (arm2-for-value-p vreg))))
    6014            (both-single-valued (and (not *arm2-open-code-inline*)
    6015                                     (eq xfer $backend-return)
    6016                                     (arm2-for-value-p vreg)
    6017                                     need-else
    6018                                     (arm2-single-valued-form-p true)
    6019                                     (arm2-single-valued-form-p false)))
    6020            (saved-reg-mask 0)
    6021            (saved-reg-map (make-array 16 :initial-element nil)))
    6022       (declare (dynamic-extent saved-reg-map))
    6023       (if (eq 0 xfer)
    6024         (setq xfer nil))
    6025       (if both-single-valued            ; it's implied that we're returning
    6026         (let* ((result arm::arg_z))
    6027           (let ((merge-else-branch-label (if (nx-null false) (arm2-find-nilret-label))))
    6028             (arm2-conditional-form seg (arm2-make-compound-cd 0 falselabel) testform)
    6029             (arm2-copy-regmap (setq saved-reg-mask *arm2-gpr-locations-valid-mask*)
    6030                               *arm2-gpr-locations*
    6031                               saved-reg-map)
    6032             (arm2-form seg result endlabel true)
    6033             (if (and merge-else-branch-label (neq -1 (aref *backend-labels* merge-else-branch-label)))
    6034               (backend-copy-label merge-else-branch-label falselabel)
     6199    (multiple-value-bind (ranges trueforms var otherwise)
     6200        #+notyet (nx2-reconstruct-case testform true false)
     6201        #-notyet (values nil nil nil nil)
     6202      (or (arm2-generate-casejump seg vreg xfer ranges trueforms var otherwise)
     6203          (let* ((cstack *arm2-cstack*)
     6204                 (vstack *arm2-vstack*)
     6205                 (top-lcell *arm2-top-vstack-lcell*)
     6206                 (entry-stack (arm2-encode-stack))
     6207                 (true-stack nil)
     6208                 (false-stack nil)
     6209                 (true-cleanup-label nil)
     6210                 (same-stack-effects nil)
     6211                 (true-is-goto (arm2-go-label true))
     6212                 (false-is-goto (and (not true-is-goto) (arm2-go-label false)))
     6213                 (endlabel (backend-get-next-label))
     6214                 (falselabel (backend-get-next-label))
     6215                 (need-else (unless false-is-goto (or (not (nx-null false)) (arm2-for-value-p vreg))))
     6216                 (both-single-valued (and (not *arm2-open-code-inline*)
     6217                                          (eq xfer $backend-return)
     6218                                          (arm2-for-value-p vreg)
     6219                                          need-else
     6220                                          (arm2-single-valued-form-p true)
     6221                                          (arm2-single-valued-form-p false)))
     6222                 (saved-reg-mask 0)
     6223                 (saved-constants-mask 0)
     6224                 (saved-reg-map (make-array 16 :initial-element nil))
     6225                 (saved-constants-map (make-array 16)))
     6226            (declare (dynamic-extent saved-reg-map saved-constants-map))
     6227            (if (eq 0 xfer)
     6228              (setq xfer nil))
     6229            (if both-single-valued      ; it's implied that we're returning
     6230              (let* ((result arm::arg_z))
     6231                (let ((merge-else-branch-label (if (nx-null false) (arm2-find-nilret-label))))
     6232                  (arm2-conditional-form seg (arm2-make-compound-cd 0 falselabel) testform)
     6233                  (arm2-copy-regmap (setq saved-reg-mask *arm2-gpr-locations-valid-mask*)
     6234                                    *arm2-gpr-locations*
     6235                                    saved-reg-map)
     6236                  (arm2-copy-constmap (setq saved-constants-mask *arm2-gpr-constants-valid-mask*)
     6237                                      *arm2-gpr-constants*
     6238                                      saved-constants-map)
     6239                  (arm2-form seg result endlabel true)
     6240                  (if (and merge-else-branch-label (neq -1 (aref *backend-labels* merge-else-branch-label)))
     6241                    (backend-copy-label merge-else-branch-label falselabel)
     6242                    (progn
     6243                      (@ falselabel)
     6244                      (arm2-predicate-block falselabel)
     6245                      (if (nx-null false) (@ (arm2-record-nilret-label)))
     6246                      (let* ((*arm2-gpr-locations-valid-mask* saved-reg-mask)
     6247                             (*arm2-gpr-locations* saved-reg-map)
     6248                             (*arm2-gpr-constants-valid-mask* saved-constants-mask)
     6249                             (*arm2-gpr-constants* saved-constants-map))
     6250                        (arm2-form seg result nil false))))
     6251                  (@ endlabel)
     6252                  (arm2-predicate-block endlabel)
     6253                  (<- result)
     6254                  (^)))
    60356255              (progn
    6036                 (@ falselabel)
    6037                 (arm2-predicate-block falselabel)
    6038                 (if (nx-null false) (@ (arm2-record-nilret-label)))
    6039                 (let* ((*arm2-gpr-locations-valid-mask* saved-reg-mask)
    6040                        (*arm2-gpr-locations* saved-reg-map))
    6041                   (arm2-form seg result nil false))))
    6042             (@ endlabel)
    6043             (arm2-predicate-block endlabel)
    6044             (<- result)
    6045             (^)))
    6046         (progn
    6047           (if (and need-else (arm2-mvpass-p xfer))
    6048             (setq true-cleanup-label (backend-get-next-label)))         
    6049           (arm2-conditional-form
    6050            seg
    6051            (arm2-make-compound-cd
    6052             (or true-is-goto 0)
    6053             (or false-is-goto
    6054                 (if need-else
    6055                   (if true-is-goto 0 falselabel)
    6056                   (if true-is-goto xfer (arm2-cd-merge xfer falselabel)))))
    6057            testform)
    6058           (arm2-copy-regmap (setq saved-reg-mask *arm2-gpr-locations-valid-mask*)
    6059                             *arm2-gpr-locations*
    6060                             saved-reg-map)
    6061           (if true-is-goto
    6062             (arm2-unreachable-store)
    6063             (if true-cleanup-label
    6064               (progn
    6065                 (arm2-open-undo $undomvexpect)
    6066                 (arm2-form seg vreg (logior $backend-mvpass-mask true-cleanup-label) true))
    6067               (arm2-form seg vreg (if need-else (arm2-cd-merge xfer endlabel) xfer) true)))
    6068           (setq true-stack (arm2-encode-stack))
    6069           (setq *arm2-cstack* cstack)
    6070           (arm2-set-vstack vstack)
    6071           (setq *arm2-top-vstack-lcell* top-lcell)
    6072           (if false-is-goto (arm2-unreachable-store))
    6073           (let ((merge-else-branch-label (if (and (nx-null false) (eq xfer $backend-return)) (arm2-find-nilret-label))))
    6074             (if (and merge-else-branch-label (neq -1 (aref *backend-labels* merge-else-branch-label)))
    6075               (backend-copy-label merge-else-branch-label falselabel)
    6076               (progn
    6077                 (@ falselabel)
    6078                 (arm2-predicate-block falselabel)
    6079                 (when need-else
     6256                (if (and need-else (arm2-mvpass-p xfer))
     6257                  (setq true-cleanup-label (backend-get-next-label)))         
     6258                (arm2-conditional-form
     6259                 seg
     6260                 (arm2-make-compound-cd
     6261                  (or true-is-goto 0)
     6262                  (or false-is-goto
     6263                      (if need-else
     6264                        (if true-is-goto 0 falselabel)
     6265                        (if true-is-goto xfer (arm2-cd-merge xfer falselabel)))))
     6266                 testform)
     6267                (arm2-copy-regmap (setq saved-reg-mask *arm2-gpr-locations-valid-mask*)
     6268                                  *arm2-gpr-locations*
     6269                                  saved-reg-map)
     6270                (arm2-copy-constmap (setq saved-constants-mask *arm2-gpr-constants-valid-mask*)
     6271                                      *arm2-gpr-constants*
     6272                                      saved-constants-map)
     6273                (if true-is-goto
     6274                  (arm2-unreachable-store)
    60806275                  (if true-cleanup-label
    6081                     (arm2-mvpass seg false)
    6082                     (let* ((*arm2-gpr-locations-valid-mask* saved-reg-mask)
    6083                            (*arm2-gpr-locations* saved-reg-map))
    6084                       (arm2-form seg vreg xfer false)))
    6085                   (setq false-stack (arm2-encode-stack))))))
    6086           (when true-cleanup-label
    6087             (if (setq same-stack-effects (arm2-equal-encodings-p true-stack false-stack)) ; can share cleanup code
    6088               (@ true-cleanup-label))
    6089             (let* ((*arm2-returning-values* :pass))
    6090               (arm2-nlexit seg xfer 1)
    6091               (arm2-branch seg (if (and xfer (neq xfer $backend-mvpass-mask)) xfer (if (not same-stack-effects) endlabel)) vreg))
    6092             (unless same-stack-effects
    6093               (@ true-cleanup-label)
    6094               (multiple-value-setq (true *arm2-cstack* *arm2-vstack* *arm2-top-vstack-lcell*)
    6095                 (arm2-decode-stack true-stack))
    6096               (let* ((*arm2-returning-values* :pass))
    6097                 (arm2-nlexit seg xfer 1)
    6098                 (^)))
    6099             (arm2-close-undo)
    6100             (multiple-value-setq (*arm2-undo-count* *arm2-cstack* *arm2-vstack* *arm2-top-vstack-lcell*)
    6101               (arm2-decode-stack entry-stack)))
    6102           (@ endlabel)
    6103           (arm2-predicate-block endlabel))))))
     6276                    (progn
     6277                      (arm2-open-undo $undomvexpect)
     6278                      (arm2-form seg vreg (logior $backend-mvpass-mask true-cleanup-label) true))
     6279                    (arm2-form seg vreg (if need-else (arm2-cd-merge xfer endlabel) xfer) true)))
     6280                (setq true-stack (arm2-encode-stack))
     6281                (setq *arm2-cstack* cstack)
     6282                (arm2-set-vstack vstack)
     6283                (setq *arm2-top-vstack-lcell* top-lcell)
     6284                (if false-is-goto (arm2-unreachable-store))
     6285                (let ((merge-else-branch-label (if (and (nx-null false) (eq xfer $backend-return)) (arm2-find-nilret-label))))
     6286                  (if (and merge-else-branch-label (neq -1 (aref *backend-labels* merge-else-branch-label)))
     6287                    (backend-copy-label merge-else-branch-label falselabel)
     6288                    (progn
     6289                      (@ falselabel)
     6290                      (arm2-predicate-block falselabel)
     6291                      (when need-else
     6292                        (if true-cleanup-label
     6293                          (arm2-mvpass seg false)
     6294                          (let* ((*arm2-gpr-locations-valid-mask* saved-reg-mask)
     6295                                 (*arm2-gpr-locations* saved-reg-map)
     6296                                 (*arm2-gpr-constants-valid-mask* saved-constants-mask)
     6297                                 (*arm2-gpr-constants* saved-constants-map))
     6298                            (arm2-form seg vreg xfer false)))
     6299                        (setq false-stack (arm2-encode-stack))))))
     6300                (when true-cleanup-label
     6301                  (if (setq same-stack-effects (arm2-equal-encodings-p true-stack false-stack)) ; can share cleanup code
     6302                    (@ true-cleanup-label))
     6303                  (let* ((*arm2-returning-values* :pass))
     6304                    (arm2-nlexit seg xfer 1)
     6305                    (arm2-branch seg (if (and xfer (neq xfer $backend-mvpass-mask)) xfer (if (not same-stack-effects) endlabel)) vreg))
     6306                  (unless same-stack-effects
     6307                    (@ true-cleanup-label)
     6308                    (multiple-value-setq (true *arm2-cstack* *arm2-vstack* *arm2-top-vstack-lcell*)
     6309                      (arm2-decode-stack true-stack))
     6310                    (let* ((*arm2-returning-values* :pass))
     6311                      (arm2-nlexit seg xfer 1)
     6312                      (^)))
     6313                  (arm2-close-undo)
     6314                  (multiple-value-setq (*arm2-undo-count* *arm2-cstack* *arm2-vstack* *arm2-top-vstack-lcell*)
     6315                    (arm2-decode-stack entry-stack)))
     6316                (@ endlabel)
     6317                (arm2-predicate-block endlabel))))))))
    61046318
    61056319(defarm2 arm2-or or (seg vreg xfer forms)
    … …  
    64486662               (if other
    64496663                 (let* ((constant (ash (or fix1 fix2) *arm2-target-fixnum-shift*))
    6450                         (reg (arm2-one-untargeted-reg-form seg other arm::arg_z)))
     6664                        (reg (arm2-one-untargeted-reg-form seg other (if (and vreg (node-reg-p vreg)) vreg arm::arg_z))))
    64516665                   (if (zerop constant)
    64526666                     (<- reg)
Note: See TracChangeset for help on using the changeset viewer.