Ignore:
Timestamp:
Dec 22, 2009, 10:28:03 PM (10 years ago)
Author:
gz
Message:

Improved compilation for some fixnum operations, %svref (r13247-r13253 from trunk)

Location:
branches/working-0711/ccl
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl

  • branches/working-0711/ccl/compiler/X86/X8632/x8632-vinsns.lisp

    r13070 r13332  
    11061106  (movl (:$l (- 8 x8632::fulltag-misc)) (:%l imm)))
    11071107
     1108(define-x8632-vinsn handle-fixnum-overflow-inline
     1109    (()
     1110     ((val :lisp)
     1111      (no-overflow
     1112       :label))
     1113     ((imm (:u32 #.x8632::imm0))
     1114      (freeptr (:lisp #.x8632::allocptr))))
     1115  (jo :overflow)
     1116  (:uuo-section)
     1117  :overflow
     1118  (movl (:%l val) (:%l imm))
     1119  (sarl (:$ub x8632::fixnumshift) (:%l imm))
     1120  (xorl (:$l #xc0000000) (:%l imm))
     1121  ;; stash bignum digit
     1122  (movd (:%l imm) (:%mmx x8632::mm1))
     1123  ;; set header
     1124  (movl (:$l x8632::one-digit-bignum-header) (:%l imm))
     1125  (movd (:%l imm) (:%mmx x8632::mm0))
     1126  ;; need 8 bytes of aligned memory for 1 digit bignum
     1127  (movl (:$l (- 8 x8632::fulltag-misc)) (:%l imm))
     1128  (subl (:%l imm) (:@ (:%seg :rcontext) x8632::tcr.save-allocptr))
     1129  (movl (:@ (:%seg :rcontext) x8632::tcr.save-allocptr) (:%l freeptr))
     1130  (rcmpl (:%l freeptr) (:@ (:%seg :rcontext) x8632::tcr.save-allocbase))
     1131  (ja :no-trap)
     1132  (uuo-alloc)
     1133  :no-trap
     1134  (movd (:%mmx x8632::mm0) (:@ x8632::misc-header-offset (:%l freeptr)))
     1135  (andb (:$b (lognot x8632::fulltagmask)) (:@ (:%seg :rcontext) x8632::tcr.save-allocptr))
     1136  ((:not (:pred = freeptr
     1137                (:apply %hard-regspec-value val)))
     1138   (movl (:%l freeptr) (:%l val)))
     1139  (movd (:%mmx x8632::mm1) (:@ x8632::misc-data-offset (:%l val)))
     1140  (jmp no-overflow))
     1141
     1142 
    11081143(define-x8632-vinsn set-bigits-after-fixnum-overflow (()
    11091144                                                      ((bignum :lisp)))
  • branches/working-0711/ccl/compiler/X86/X8664/x8664-vinsns.lisp

    r13306 r13332  
    12431243  (negq (:% val)))
    12441244
     1245(define-x8664-vinsn handle-fixnum-overflow-inline
     1246    (()
     1247     ((val :lisp)
     1248      (no-overflow :label))
     1249     ((header (:u64 #.x8664::imm0))
     1250      (scaled-size (:u64 #.x8664::imm1))
     1251      (freeptr (:lisp #.x8664::allocptr))))
     1252  (jo :overflow)
     1253  (:uuo-section)
     1254  :overflow
     1255  (movq (:%q val) (:%q scaled-size))
     1256  (btcq (:$ub 63) (:%q scaled-size))
     1257  (sarq (:$ub x8664::fixnumshift) (:%q scaled-size))
     1258  (btcq (:$ub 60) (:%q scaled-size))
     1259  (movd (:%q scaled-size) (:%mmx x8664::mm0))
     1260  (movq (:$l x8664::two-digit-bignum-header) (:%q header))
     1261  (movq (:$l (- 16 x8664::fulltag-misc)) (:%q scaled-size))
     1262  (subq (:%q scaled-size) (:rcontext x8664::tcr.save-allocptr))
     1263  (movq (:rcontext x8664::tcr.save-allocptr) (:%q freeptr))
     1264  (rcmpq (:%q freeptr) (:rcontext x8664::tcr.save-allocbase))
     1265  (:byte #x77) (:byte #x02)             ;(ja :no-trap)
     1266  (uuo-alloc)
     1267  :no-trap
     1268  (movq (:%q header) (:@ x8664::misc-header-offset (:%q freeptr)))
     1269  (andb (:$b (lognot x8664::fulltagmask)) (:rcontext x8664::tcr.save-allocptr))
     1270  ((:not (:pred = freeptr
     1271                (:apply %hard-regspec-value val)))
     1272   (movq (:%q freeptr) (:%q val)))
     1273  (movq (:%mmx x8664::mm0) (:@ x8664::misc-data-offset (:%q val)))
     1274  (jmp no-overflow))
     1275
     1276   
    12451277;;; This handles the 1-bit overflow from addition/subtraction/unary negation
    12461278(define-x8664-vinsn set-bigits-and-header-for-fixnum-overflow
  • branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp

    r13146 r13332  
    119119         (high (x86-ds-next-u16 ds)))
    120120    (declare (type (unsigned-byte 16) low high))
    121     (logior (the fixnum (ash high 16)) low)))
     121    (logior (ash high 16) low)))
    122122
    123123(defun x86-ds-next-s32 (ds)
     
    126126    (declare (type (unsigned-byte 16) low)
    127127             (type (signed-byte 16) high))
    128     (logior (the fixnum (ash high 16)) low)))
     128    (logior (ash high 16) low)))
    129129
    130130(defun x86-ds-next-u64 (ds)
    131131  (let* ((low (x86-ds-next-u32 ds))
    132132         (high (x86-ds-next-u32 ds)))
    133     (logior (the fixnum (ash high 32)) low)))
     133    (logior (ash high 32) low)))
    134134
    135135(defun x86-ds-next-s64 (ds)
    136136  (let* ((low (x86-ds-next-u32 ds))
    137137         (high (x86-ds-next-s32 ds)))
    138     (logior (the fixnum (ash high 32)) low)))
     138    (logior (ash high 32) low)))
    139139
    140140(defun used-rex (ds value)
  • branches/working-0711/ccl/compiler/X86/x862.lisp

    r13165 r13332  
    13011301    (if *x862-open-code-inline*
    13021302      (let* ((no-overflow (backend-get-next-label)))
    1303         (! set-bigits-and-header-for-fixnum-overflow target (aref *backend-labels* (or labelno no-overflow)))
    1304         (! %allocate-uvector target)
    1305         (! set-bigits-after-fixnum-overflow target)
    1306         (when labelno
    1307           (-> labelno))
     1303        (! handle-fixnum-overflow-inline target (aref *backend-labels* (or labelno no-overflow)))
     1304        (when labelno (-> labelno))
    13081305        (@ no-overflow))
    13091306      (if labelno
     
    25112508                                                  value result-reg)))
    25122509                (:x8664
    2513                  (multiple-value-setq (src unscaled-idx result-reg)
    2514                    (x862-three-untargeted-reg-forms seg
     2510                 (if (and index-known-fixnum
     2511                          (not safe)
     2512                          (nx2-constant-index-ok-for-type-keyword index-known-fixnum type-keyword))
     2513                   (multiple-value-setq (src result-reg unscaled-idx)
     2514                     (x862-two-untargeted-reg-forms seg
    25152515                                                  vector src
    2516                                                   index unscaled-idx
    2517                                                   value result-reg))))))
     2516                                                  value result-reg))
     2517                   (multiple-value-setq (src unscaled-idx result-reg)
     2518                     (x862-three-untargeted-reg-forms seg
     2519                                                      vector src
     2520                                                      index unscaled-idx
     2521                                                      value result-reg)))))))
    25182522        (when safe
    25192523          (let* ((*available-backend-imm-temps* *available-backend-imm-temps*)
     
    29842988    (or (x86-constant-form-p form)
    29852989        ;(eq (acode-operator form) (%nx1-operator bound-special-ref))
     2990        (and (eq (acode-operator form) (%nx1-operator %svref))
     2991             (destructuring-bind (v i) (acode-operands form)
     2992               (let* ((idx (acode-fixnum-form-p i)))
     2993                 (and idx
     2994                      (nx2-constant-index-ok-for-type-keyword idx :simple-vector)
     2995                      (consp (setq v (acode-unwrapped-form-value v)))
     2996                      (eq (acode-operator v) (%nx1-operator lexical-reference))
     2997                      (let* ((var (cadr v)))
     2998                        (unless (%ilogbitp $vbitsetq (nx-var-bits var))
     2999                          (var-nvr var)))))))
    29863000        (if (eq (acode-operator form) (%nx1-operator lexical-reference))
    29873001          (not (%ilogbitp $vbitsetq (nx-var-bits (%cadr form))))))))
     
    43704384              (progn
    43714385                (nx-set-var-bits var (%ilogior (%ilsl $vbitpunted 1) bits))
     4386                (let* ((vtype (var-inittype var)))
     4387                  (when (and vtype (not (eq t vtype)))
     4388                    (setq puntval (make-acode (%nx1-operator typed-form)
     4389                                              vtype
     4390                                              puntval
     4391                                              nil))))
    43724392                (nx2-replace-var-refs var puntval)
    43734393                (x862-set-var-ea seg var puntval))
  • branches/working-0711/ccl/compiler/nx1.lisp

    r13156 r13332  
    454454                      (%nx1-operator %natural-logand)))
    455455
    456 (defnx1 nx1-require ((require-simple-vector) (require-simple-string) (require-integer) (require-list)
    457                      (require-fixnum) (require-real) (require-character) (require-number) (require-symbol) (require-s8) (require-u8) (require-s16) (require-u16) (require-s32) (require-u32) (require-s64) (require-u64))
    458         (arg)
    459   (make-acode (%nx1-default-operator) (nx1-form arg)))
     456(defnx1 nx1-require ((require-simple-vector)
     457                     (require-simple-string)
     458                     (require-integer)
     459                     (require-list)
     460                     (require-fixnum)
     461                     (require-real)
     462                     (require-character)
     463                     (require-number)
     464                     (require-symbol)
     465                     (require-s8)
     466                     (require-u8)
     467                     (require-s16)
     468                     (require-u16)
     469                     (require-s32)
     470                     (require-u32)
     471                     (require-s64)
     472                     (require-u64))
     473        (arg &environment env)
     474
     475  (if (nx-inhibit-safety-checking env)
     476    (let* ((op *nx-sfname*)
     477           (type (case op
     478                   (require-simple-vector 'simple-vector)
     479                   (require-simple-string 'simple-string)
     480                   (require-integer 'integer)
     481                     (require-list 'list)
     482                     (require-fixnum 'fixnum)
     483                     (require-real 'real)
     484                     (require-character 'charater)
     485                     (require-number 'number)
     486                     (require-symbol 'symbol)
     487                     (require-s8 '(signed-byte 8))
     488                     (require-u8 '(unsigned-byte 8))
     489                     (require-s16 '(signed-byte 16))
     490                     (require-u16 '(unsigned-byte 16))
     491                     (require-s32 '(signed-byte 32))
     492                     (require-u32 '(unsigned-byte 32))
     493                     (require-s64 '(signed-byte 64))
     494                     (require-u64 '(unsigned-byte 64)))))
     495      (nx1-form `(the ,type ,arg)))
     496    (make-acode (%nx1-default-operator) (nx1-form arg))))
    460497
    461498(defnx1 nx1-%marker-marker ((%unbound-marker) (%slot-unbound-marker) (%illegal-marker)) ()
  • branches/working-0711/ccl/compiler/nx2.lisp

    r13165 r13332  
    242242      (cadr x)
    243243      (compiler-bug "not an immediate: ~s" x))))
     244
     245(defun nx2-constant-index-ok-for-type-keyword (idx keyword)
     246  (when (>= idx 0)
     247    (let* ((arch (backend-target-arch *target-backend*))
     248           (limit
     249            (case keyword
     250              ((:bignum
     251                :single-float
     252                :double-float
     253                :xcode-vector
     254                :signed-32-bit-vector
     255                :unsigned-32-bit-vector
     256                :single-float-vector
     257                :simple-string)
     258               (arch::target-max-32-bit-constant-index arch))
     259              (:bit-vector (arch::target-max-1-bit-constant-index arch))
     260              ((:signed-8-bit-vector :unsigned-8-bit-vector)
     261               (arch::target-max-8-bit-constant-index arch))
     262              ((:signed-16-bit-vector :unsigned-16-bit-vector)
     263               (arch::target-max-16-bit-constant-index arch))
     264              ((:signed-64-bit-vector
     265                :unsigned-64-bit-vector
     266                :double-float-vector)
     267               (arch::target-max-64-bit-constant-index arch))
     268              (t
     269               ;; :fixnum or node
     270               (target-word-size-case
     271                (32 (arch::target-max-32-bit-constant-index arch))
     272                (64 (arch::target-max-64-bit-constant-index arch)))))))
     273      (and limit (< idx limit)))))
  • branches/working-0711/ccl/compiler/optimizers.lisp

    r13331 r13332  
    12221222      `(/=-2 ,n0 ,n1))))
    12231223
    1224 (define-compiler-macro + (&optional (n0 nil n0p) (n1 nil n1p) &rest more)
     1224(define-compiler-macro + (&optional (n0 nil n0p) (n1 nil n1p) &rest more &environment env)
    12251225  (if more
    1226     `(+ (+-2 ,n0 ,n1) ,@more)
     1226    (if (and (nx-trust-declarations env)
     1227             (subtypep *nx-form-type* 'fixnum)
     1228             (nx-form-typep n0 'fixnum env)
     1229             (nx-form-typep n1 'fixnum env)
     1230             (dolist (m more t)
     1231               (unless (nx-form-typep m 'fixnum env)
     1232                 (return nil))))
     1233      `(+-2 ,n0 (the fixnum (+ ,n1 ,@more)))
     1234      `(+ (+-2 ,n0 ,n1) ,@more))
    12271235    (if n1p
    12281236      `(+-2 ,n0 ,n1)
Note: See TracChangeset for help on using the changeset viewer.