Changeset 15805


Ignore:
Timestamp:
May 7, 2013, 7:25:38 AM (7 years ago)
Author:
gb
Message:

Enable *NX-REWRITE-ACODE*.

Don't constant-fold %SVREF. (Todo: think about this more carefully.
Problems caused by constant-folding a package-ref, apparently.)

Compiler-macro on GETF.

GVECTORP shouldn't be true of SYMBOLs on X8664. It has been ...

Location:
branches/acode-rewrite/source
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • branches/acode-rewrite/source/compiler/acode-rewrite.lisp

    r15801 r15805  
    278278             (bits (nx-var-bits var)))
    279279        (declare (fixnum bits))
    280         (unless (logbitp $vbitpunted bits)
     280        (unless (and (logbitp $vbitpunted bits)
     281                     (not (logbitp $vbitspecial bits)))
    281282          (cond ((logbitp $vbitpuntable bits)
    282283                 (nx-set-var-bits var (logior (ash 1 $vbitpunted) bits))
     
    306307
    307308
    308 (def-acode-rewrite acode-rewrite-svref (%svref svref) asserted-type (&whole w vector idx)
     309(def-acode-rewrite acode-rewrite-svref svref asserted-type (&whole w vector idx)
    309310  (rewrite-acode-form vector)
    310311  (rewrite-acode-form idx )
    311312  (let* ((cv (acode-constant-p vector)))
    312     (when (if (eql (car w) (%nx1-operator svref))
    313             (typep cv 'simple-vector)
    314             (gvectorp cv))
     313    (when (and (typep cv 'simple-vector)
     314               (eql (acode-operator w) (%nx1-operator svref)))
    315315      (let* ((cidx (acode-fixnum-form-p idx)))
    316316        (when (and (typep cidx 'fixnum)
     
    331331            t))))))
    332332
     333(def-acode-rewrite acode-rewrite-%svref %svref asserted-type (vector i)
     334  (rewrite-acode-form vector)
     335  (rewrite-acode-form i))
     336
     337
    333338(def-acode-rewrite acode-rewrite-%sbchar %sbchar  asserted-type (&whole w string idx)
    334339  (rewrite-acode-form string)
     
    429434(def-acode-rewrite rewrite-nullary (t nil %unbound-marker %slot-unbound-marker %illegal-marker %current-tcr %foreign-stack-pointer %current-frame-ptr %interrupt-poll) asserted-type (&whole w))
    430435
    431 (def-acode-rewrite rewrite-call (call lexical-function-call builtin-call multiple-value-call) asserted-type (&whole w callable arglist &optional spread-p)
     436(def-acode-rewrite rewrite-call (call lexical-function-call builtin-call) asserted-type (&whole w callable arglist &optional spread-p)
    432437  (declare (ignore spread-p))
    433438  (when (acode-p callable)
     
    576581(def-acode-rewrite acode-rewrite-with-c-frame with-c-frame asserted-type (body)
    577582  (rewrite-acode-form body asserted-type))
     583
     584(def-acode-rewrite acode-rewrite-ash ash asserted-type (&whole w num amt)
     585  (let* ((cnum (acode-constant-p num))
     586         (camt (acode-constant-p amt))
     587         (result (and (typep cnum 'integer)
     588                      (typep camt 'integer)
     589                      (ignore-errors (ash cnum camt)))))
     590    (if result
     591      (setf (acode-operator w) (if (typep result *nx-target-fixnum-type*)
     592                                 (%nx1-operator fixnum)
     593                                 (%nx1-operator immediate))
     594            (acode-operands w) (cons result nil))
     595      (let* ((maxbits (target-word-size-case
     596                       (32 29)
     597                       (64 60)))
     598             (trust-decls *acode-rewrite-trust-declarations*)
     599             (fixnum-type *nx-target-fixnum-type*)
     600             (natural-type *nx-target-natural-type*))
     601        (cond ((eql camt 0) (setf (acode-operator w) (%nx1-operator require-integer)
     602                                  (cdr (acode-operands w)) nil))
     603              ((and (typep camt fixnum-type)
     604                    (< camt 0))
     605               (if (acode-form-typep num fixnum-type trust-decls)
     606                 (setf (acode-operator w) (%nx1-operator %iasr)
     607                       (acode-operands w) (list (make-acode (%nx1-operator fixnum)
     608                                                            (- camt))
     609                                                num))
     610                 (if (acode-form-typep num natural-type trust-decls)
     611                   (if (< (- camt) (arch::target-nbits-in-word
     612                                    (backend-target-arch *target-backend*)))
     613                     (setf (acode-operator w) (%nx1-operator natural-shift-right)
     614                           (cadr (acode-operands w)) (make-acode (%nx1-operator fixnum) (- camt)))
     615
     616                     (setf (acode-operator w) (%nx1-operator progn)
     617                           (acode-operands w) (list (list (make-acode (%nx1-operator require-integer) num)
     618                                                          (make-acode (%nx1-operator fixnum) 0))))))))
     619              ((and (typep camt 'fixnum)
     620                    (<= 0 camt maxbits)
     621                    (or (acode-form-typep num `(signed-byte ,(- (1+ maxbits) camt)) trust-decls)
     622                        (and (acode-form-typep num fixnum-type trust-decls)
     623                             (subtypep asserted-type fixnum-type))))
     624               (setf (acode-operator w) (%nx1-operator %ilsl)
     625                     (acode-operands w) (list amt num)))
     626              ((and (typep camt 'fixnum)
     627                    (< 0 camt (arch::target-nbits-in-word
     628                               (backend-target-arch *target-backend*)))
     629                    (acode-form-typep num natural-type trust-decls)
     630                    (subtypep asserted-type natural-type))
     631               (setf (acode-operator w) (%nx1-operator natural-shift-left)))
     632              ((typep cnum 'fixnum)
     633               (let* ((field-width (1+ (integer-length cnum)))
     634                      ;; num fits in a `(signed-byte ,field-width)
     635                      (max-shift (- (1+ maxbits) field-width)))
     636                 (if (acode-form-typep amt `(mod ,(1+ max-shift)) trust-decls)
     637                   (setf (acode-operator w) (%nx1-operator %ilsl)
     638                         (acode-operands w) (list amt num)))))
     639              ((or (and (subtypep asserted-type fixnum-type)
     640                        (acode-form-typep num fixnum-type trust-decls)
     641                        (target-word-size-case
     642                         (32 (acode-form-typep amt '(signed-byte 5) trust-decls))
     643                         (64 (acode-form-typep amt '(signed-byte 6) trust-decls))))
     644                   (let* ((numtype (specifier-type (acode-form-type num trust-decls)))
     645                          (amttype (specifier-type (acode-form-type amt trust-decls)))
     646                          (fixtype (specifier-type fixnum-type)))
     647                     (if (and (typep numtype 'numeric-ctype)
     648                              (csubtypep numtype fixtype)
     649                              (typep amttype 'numeric-ctype)
     650                              (csubtypep amttype fixtype))
     651                       (let* ((highnum (numeric-ctype-high numtype))
     652                              (lownum (numeric-ctype-low numtype))
     653                              (widenum (if (> (integer-length highnum)
     654                                              (integer-length lownum))
     655                                         highnum
     656                                         lownum))
     657                              (maxleft (numeric-ctype-high amttype)))
     658                         
     659                         (and (>= (numeric-ctype-low amttype)
     660                                        (target-word-size-case
     661                                         (32 -31)
     662                                         (64 -63)))
     663                                    (< maxleft
     664                                       (arch::target-nbits-in-word (backend-target-arch *target-backend*)))
     665                                    (typep (ignore-errors (ash widenum maxleft))
     666                                           fixnum-type))))))
     667               (setf (acode-operator w) (%nx1-operator fixnum-ash))))))))
     668
     669(def-acode-rewrite acode-rewrite-multiple-value-call multiple-value-call asserted-type (callable formlist)
     670  (when (acode-p callable)
     671    (rewrite-acode-form callable))
     672  (dolist (form formlist) (rewrite-acode-form form)))
  • branches/acode-rewrite/source/compiler/nx.lisp

    r15795 r15805  
    219219
    220220(defparameter *nx-in-frontend* nil)
    221 (defparameter *nx-rewrite-acode* nil)
     221(defparameter *nx-rewrite-acode* t)
    222222
    223223
  • branches/acode-rewrite/source/compiler/optimizers.lisp

    r15618 r15805  
    408408      (dolist (,pair ,listx)
    409409        (when (and ,pair (eq (car ,pair) ,itemx)) (return ,pair))))))
     410
     411(define-compiler-macro getf (plist item &optional missing)
     412  (let* ((i (gensym))
     413         (l (gensym))
     414         (m (gensym)))
     415    `(do* ((,l ,plist (cddr ,l))
     416           (,i ,item)
     417           (,m ,missing))
     418      ((null ,l) ,m)
     419      (if (eq ,i (car ,l))
     420        (return (cadr ,l))))))
    410421
    411422(define-compiler-macro caar (form)
  • branches/acode-rewrite/source/level-0/X86/x86-symbol.lisp

    r13752 r15805  
    6060  (movw ($ (ash 1 x8664::fulltag-symbol)) (% imm0.w))
    6161  (btw (%w symptr) (% imm0.w))
    62   (jb.pt @ok)
     62  (jb @ok)
    6363  (uuo-error-reg-not-tag (% symptr) ($ x8664::fulltag-symbol))
    6464  @ok
  • branches/acode-rewrite/source/level-0/l0-pred.lisp

    r15601 r15805  
    201201  (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-nodeheader)
    202202  #+x8664-target
    203   (let* ((fulltag (logand (the fixnum (typecode x)) x8664::fulltagmask)))
     203  (let* ((fulltag (fulltag x)))
    204204    (declare (fixnum fulltag))
    205     (or (= fulltag x8664::fulltag-nodeheader-0)
    206         (= fulltag x8664::fulltag-nodeheader-1)))
     205    (when (= fulltag x8664::fulltag-misc)
     206      (setq fulltag (logand (the (unsigned-byte 8) (typecode x)) x8664::fulltagmask))
     207      (or (= fulltag x8664::fulltag-nodeheader-0)
     208          (= fulltag x8664::fulltag-nodeheader-1))))
    207209  )
    208210
Note: See TracChangeset for help on using the changeset viewer.