X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=4bb3a9f9fe8db40bedba9a7f4822ff91e1484c2c;hb=5c139b13882a2632a27a7f8fd81c8f1ab62b10a0;hp=3298c81cf5fae9dff07e20ff1f6d1cb3521517db;hpb=03df95052f395c205d7e5028e06bc043ee60125d;p=sbcl.git diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 3298c81..4bb3a9f 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -46,13 +46,14 @@ (if (array-type-p ctype) ;; the other transform will kick in, so that's OK (give-up-ir1-transform) - `(typecase string + `(etypecase string ((simple-array character (*)) (data-vector-ref string index)) ((simple-array nil (*)) (data-vector-ref string index)))))) (deftransform hairy-data-vector-ref ((array index) (array t) * :important t) "avoid runtime dispatch on array element type" - (let ((element-ctype (extract-upgraded-element-type array))) + (let ((element-ctype (extract-upgraded-element-type array)) + (declared-element-ctype (extract-declared-element-type array))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform @@ -65,7 +66,11 @@ `(multiple-value-bind (array index) (%data-vector-and-index array index) (declare (type (simple-array ,element-type-specifier 1) array)) - (data-vector-ref array index))))) + ,(let ((bare-form '(data-vector-ref array index))) + (if (type= element-ctype declared-element-ctype) + bare-form + `(the ,(type-specifier declared-element-ctype) + ,bare-form))))))) (deftransform data-vector-ref ((array index) (simple-array t)) @@ -84,12 +89,25 @@ (%array-data-vector array)) index))))) +(deftransform hairy-data-vector-set ((string index new-value) + (simple-string t t)) + (let ((ctype (continuation-type string))) + (if (array-type-p ctype) + ;; the other transform will kick in, so that's OK + (give-up-ir1-transform) + `(etypecase string + ((simple-array character (*)) + (data-vector-set string index new-value)) + ((simple-array nil (*)) + (data-vector-set string index new-value)))))) + (deftransform hairy-data-vector-set ((array index new-value) (array t t) * :important t) "avoid runtime dispatch on array element type" - (let ((element-ctype (extract-upgraded-element-type array))) + (let ((element-ctype (extract-upgraded-element-type array)) + (declared-element-ctype (extract-declared-element-type array))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform @@ -99,21 +117,12 @@ (%data-vector-and-index array index) (declare (type (simple-array ,element-type-specifier 1) array) (type ,element-type-specifier new-value)) - (data-vector-set array - index - new-value))))) - -(deftransform hairy-data-vector-set ((string index new-value) - (simple-string t t)) - (let ((ctype (continuation-type string))) - (if (array-type-p ctype) - ;; the other transform will kick in, so that's OK - (give-up-ir1-transform) - `(typecase string - ((simple-array character (*)) - (data-vector-set string index new-value)) - ((simple-array nil (*)) - (data-vector-set string index new-value)))))) + ,(if (type= element-ctype declared-element-ctype) + '(data-vector-set array index new-value) + `(truly-the ,(type-specifier declared-element-ctype) + (data-vector-set array index + (the ,(type-specifier declared-element-ctype) + new-value)))))))) (deftransform data-vector-set ((array index new-value) (simple-array t t)) @@ -331,6 +340,55 @@ (declare (type (unsigned-byte 32) numx numy)) (unless (= numx numy) (return nil)))))))) + +(deftransform fill ((sequence item) (simple-bit-vector bit) * + :policy (>= speed space)) + (let ((value (if (constant-continuation-p item) + (if (= (continuation-value item) 0) + 0 + #.(1- (ash 1 32))) + `(if (= item 0) 0 #.(1- (ash 1 32)))))) + `(let ((length (length sequence)) + (value ,value)) + (if (= length 0) + sequence + (do ((index sb!vm:vector-data-offset (1+ index)) + (end-1 (+ sb!vm:vector-data-offset + ;; bit-vectors of length 1-32 need precisely + ;; one (SETF %RAW-BITS), done here in the + ;; epilogue. - CSR, 2002-04-24 + (truncate (truly-the index (1- length)) + sb!vm:n-word-bits)))) + ((= index end-1) + (setf (%raw-bits sequence index) value) + sequence) + (declare (optimize (speed 3) (safety 0)) + (type index index end-1)) + (setf (%raw-bits sequence index) value)))))) + +(deftransform fill ((sequence item) (simple-base-string base-char) * + :policy (>= speed space)) + (let ((value (if (constant-continuation-p item) + (let* ((char (continuation-value item)) + (code (sb!xc:char-code char))) + (logior code (ash code 8) (ash code 16) (ash code 24))) + `(let ((code (sb!xc:char-code item))) + (logior code (ash code 8) (ash code 16) (ash code 24)))))) + `(let ((length (length sequence)) + (value ,value)) + (multiple-value-bind (times rem) + (truncate length 4) + (do ((index sb!vm:vector-data-offset (1+ index)) + (end (+ times sb!vm:vector-data-offset))) + ((= index end) + (let ((place (* times 4))) + (declare (fixnum place)) + (dotimes (j rem sequence) + (declare (index j)) + (setf (schar sequence (the index (+ place j))) item)))) + (declare (optimize (speed 3) (safety 0)) + (type index index)) + (setf (%raw-bits sequence index) value)))))) ;;;; %BYTE-BLT @@ -380,3 +438,73 @@ '(and (= (double-float-low-bits x) (double-float-low-bits y)) (= (double-float-high-bits x) (double-float-high-bits y)))) + +;;;; 32-bit operations +#!-x86 ; on X86 it is a modular function +(deftransform lognot ((x) ((unsigned-byte 32)) * + :node node + :result result) + "32-bit implementation" + (let ((dest (continuation-dest result))) + (unless (and (combination-p dest) + (eq (continuation-fun-name (combination-fun dest)) + 'logand)) + (give-up-ir1-transform)) + (unless (some (lambda (arg) + (csubtypep (continuation-type arg) + (specifier-type '(unsigned-byte 32)))) + (combination-args dest)) + (give-up-ir1-transform)) + (setf (node-derived-type node) + (values-specifier-type '(values (unsigned-byte 32) &optional))) + '(32bit-logical-not x))) + +(define-good-modular-fun logand) +(define-good-modular-fun logior) + +;;; There are two different ways the multiplier can be recoded. The +;;; more obvious is to shift X by the correct amount for each bit set +;;; in Y and to sum the results. But if there is a string of bits that +;;; are all set, you can add X shifted by one more then the bit +;;; position of the first set bit and subtract X shifted by the bit +;;; position of the last set bit. We can't use this second method when +;;; the high order bit is bit 31 because shifting by 32 doesn't work +;;; too well. +(defun ub32-strength-reduce-constant-multiply (arg num) + (declare (type (unsigned-byte 32) numb)) + (let ((adds 0) (shifts 0) + (result nil) first-one) + (labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x)) + (add (next-factor) + (setf result + (tub32 + (if result + (progn (incf adds) `(+ ,result ,(tub32 next-factor))) + next-factor))))) + (declare (inline add)) + (dotimes (bitpos 32) + (if first-one + (when (not (logbitp bitpos num)) + (add (if (= (1+ first-one) bitpos) + ;; There is only a single bit in the string. + (progn (incf shifts) `(ash ,arg ,first-one)) + ;; There are at least two. + (progn + (incf adds) + (incf shifts 2) + `(- ,(tub32 `(ash ,arg ,bitpos)) + ,(tub32 `(ash ,arg ,first-one)))))) + (setf first-one nil)) + (when (logbitp bitpos num) + (setf first-one bitpos)))) + (when first-one + (cond ((= first-one 31)) + ((= first-one 30) (incf shifts) (add `(ash ,arg 30))) + (t + (incf shifts 2) + (incf adds) + (add `(- ,(tub32 `(ash ,arg 31)) + ,(tub32 `(ash ,arg ,first-one)))))) + (incf shifts) + (add `(ash ,arg 31)))) + (values result adds shifts)))