0.8.3:

[sbcl.git] / src / compiler / generic / vm-tran.lisp

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 68935a6..3f17ce6 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -340,6 +340,38 @@
                  (declare (type (unsigned-byte 32) numx numy))
                  (unless (= numx numy)
                    (return nil))))))))
+
+;;; FIXME: it is probably worth doing something like this for
+;;; SIMPLE-BASE-STRINGs too, if only so that (MAKE-STRING 100000
+;;; :INITIAL-ELEMENT #\Space) doesn't surprise the user with its
+;;; performance characteristics.  Getting it right is harder than with
+;;; bit-vectors, though, as one needs to be more careful with the loop
+;;; epilogue so as not to overwrite the convenient extra null byte
+;;; (for SB-ALIEN/C termination convention convenience).
+(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))))))
 \f
 ;;;; %BYTE-BLT
 
@@ -389,3 +421,26 @@
   '(and (= (double-float-low-bits x) (double-float-low-bits y))
        (= (double-float-high-bits x) (double-float-high-bits y))))
 
+\f
+;;;; 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)