X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=b4b1adbc9448db98313dbb94cce84b3b426e83ba;hb=670d28c10c178142146f6916c5fa0967732f3a8f;hp=2542c12cb224d5e4f03a6a299e64bdcddacd8584;hpb=f12f2c5a8ae794dc414dd6a42e0b25740d576aa1;p=sbcl.git

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 2542c12..b4b1adb 100644
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -19,7 +19,12 @@
 (define-source-transform long-float-p (x) `(double-float-p ,x))
 
 (define-source-transform compiled-function-p (x)
-  `(functionp ,x))
+  #!-sb-eval
+  `(functionp ,x)
+  #!+sb-eval
+  (once-only ((x x))
+    `(and (functionp ,x)
+          (not (sb!eval:interpreted-function-p ,x)))))
 
 (define-source-transform char-int (x)
   `(char-code ,x))
@@ -79,6 +84,8 @@
                 `(the ,(type-specifier declared-element-ctype)
                       ,bare-form)))))))
 
+;;; Transform multi-dimensional array to one dimensional data vector
+;;; access.
 (deftransform data-vector-ref ((array index)
                                (simple-array t))
   (let ((array-type (lvar-type array)))
@@ -258,7 +265,7 @@
                                        ;; epilogue. - CSR, 2002-04-24
                                        (truncate (truly-the index (1- length))
                                                  sb!vm:n-word-bits))))
-                            ((= index end-1)
+                            ((>= index end-1)
                              (setf (%raw-bits result-bit-array index)
                                    (,',wordfun (%raw-bits bit-array-1 index)
                                                (%raw-bits bit-array-2 index)))
@@ -304,7 +311,7 @@
                          ;; the epilogue. - CSR, 2002-04-24
                          (truncate (truly-the index (1- length))
                                    sb!vm:n-word-bits))))
-              ((= index end-1)
+              ((>= index end-1)
                (setf (%raw-bits result-bit-array index)
                      (word-logical-not (%raw-bits bit-array index)))
                result-bit-array)
@@ -320,7 +327,7 @@
               (do* ((i sb!vm:vector-data-offset (+ i 1))
                     (end-1 (+ sb!vm:vector-data-offset
                               (floor (1- length) sb!vm:n-word-bits))))
-                   ((= i end-1)
+                   ((>= i end-1)
                     (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
                            (mask (ash #.(1- (ash 1 sb!vm:n-word-bits))
                                       (- extra sb!vm:n-word-bits)))
@@ -360,7 +367,7 @@
              (end-1 (+ sb!vm:vector-data-offset
                        (truncate (truly-the index (1- length))
                                  sb!vm:n-word-bits))))
-            ((= index end-1)
+            ((>= index end-1)
              (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
                     (mask (ash #.(1- (ash 1 sb!vm:n-word-bits))
                                (- extra sb!vm:n-word-bits)))
@@ -372,24 +379,17 @@
                                   (%raw-bits sequence index))))
                (declare (type (integer 1 #.sb!vm:n-word-bits) extra))
                (declare (type sb!vm:word mask bits))
-               ;; could consider LOGNOT for the zero case instead of
-               ;; doing the subtraction...
-               (incf count ,(if (constant-lvar-p item)
-                                (if (zerop (lvar-value item))
-                                    '(- extra (logcount bits))
-                                    '(logcount bits))
-                                '(if (zerop item)
-                                     (- extra (logcount bits))
-                                     (logcount bits))))))
+               (incf count (logcount bits))
+               ,(if (constant-lvar-p item)
+                    (if (zerop (lvar-value item))
+                        '(- length count)
+                        'count)
+                    '(if (zerop item)
+                         (- length count)
+                         count))))
           (declare (type index index count end-1)
                    (optimize (speed 3) (safety 0)))
-          (incf count ,(if (constant-lvar-p item)
-                           (if (zerop (lvar-value item))
-                               '(- sb!vm:n-word-bits (logcount (%raw-bits sequence index)))
-                               '(logcount (%raw-bits sequence index)))
-                           '(if (zerop item)
-                             (- sb!vm:n-word-bits (logcount (%raw-bits sequence index)))
-                             (logcount (%raw-bits sequence index)))))))))
+          (incf count (logcount (%raw-bits sequence index)))))))
 
 (deftransform fill ((sequence item) (simple-bit-vector bit) *
                     :policy (>= speed space))
@@ -409,7 +409,7 @@
                           ;; in the epilogue. - CSR, 2002-04-24
                           (truncate (truly-the index (1- length))
                                     sb!vm:n-word-bits))))
-               ((= index end-1)
+               ((>= index end-1)
                 (setf (%raw-bits sequence index) value)
                 sequence)
              (declare (optimize (speed 3) (safety 0))
@@ -433,7 +433,7 @@
           (truncate length sb!vm:n-word-bytes)
         (do ((index sb!vm:vector-data-offset (1+ index))
              (end (+ times sb!vm:vector-data-offset)))
-            ((= index end)
+            ((>= index end)
              (let ((place (* times sb!vm:n-word-bytes)))
                (declare (fixnum place))
                (dotimes (j rem sequence)