More efficient MASK-SIGNED-FIELD

[sbcl.git] / src / compiler / ir2tran.lisp

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 0ae854b..24bccb7 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -1272,7 +1272,10 @@
 
     (let ((lab (gen-label)))
       (setf (ir2-physenv-environment-start env) lab)
-      (vop note-environment-start node block lab)))
+      (vop note-environment-start node block lab)
+      #!+sb-safepoint
+      (unless (policy fun (>= inhibit-safepoints 2))
+        (vop sb!vm::insert-safepoint node block))))
 
   (values))
 \f
@@ -1539,8 +1542,7 @@
              (progn
                (labels ((,unbind (vars)
                           (declare (optimize (speed 2) (debug 0)))
-                          (let ((unbound-marker (%primitive make-other-immediate-type
-                                                            0 sb!vm:unbound-marker-widetag)))
+                          (let ((unbound-marker (%primitive make-unbound-marker)))
                             (dolist (var vars)
                               ;; CLHS says "bound and then made to have no value" -- user
                               ;; should not be able to tell the difference between that and this.
@@ -1765,6 +1767,46 @@
   (def list*))
 
 \f
+(defoptimizer (mask-signed-field ir2-convert) ((width x) node block)
+  (block nil
+    (when (constant-lvar-p width)
+      (case (lvar-value width)
+        (#.(- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)
+         (when (or (csubtypep (lvar-type x)
+                              (specifier-type 'word))
+                   (csubtypep (lvar-type x)
+                              (specifier-type 'sb!vm:signed-word)))
+           (let* ((lvar (node-lvar node))
+                  (temp (make-normal-tn
+                         (if (csubtypep (lvar-type x)
+                                        (specifier-type 'word))
+                             (primitive-type-of most-positive-word)
+                             (primitive-type-of
+                              (- (ash most-positive-word -1))))))
+                  (results (lvar-result-tns
+                            lvar
+                            (list (primitive-type-or-lose 'fixnum)))))
+             (emit-move node block (lvar-tn node block x) temp)
+             (vop sb!vm::move-from-word/fixnum node block
+                  temp (first results))
+             (move-lvar-result node block results lvar)
+             (return))))
+        (#.sb!vm:n-word-bits
+         (when (csubtypep (lvar-type x) (specifier-type 'word))
+           (let* ((lvar (node-lvar node))
+                  (temp (make-normal-tn
+                         (primitive-type-of most-positive-word)))
+                  (results (lvar-result-tns
+                            lvar
+                            (list (primitive-type
+                                   (specifier-type 'sb!vm:signed-word))))))
+             (emit-move node block (lvar-tn node block x) temp)
+             (vop sb!vm::word-move node block
+                  temp (first results))
+             (move-lvar-result node block results lvar)
+             (return))))))
+    (ir2-convert-full-call node block)))
+\f
 ;;; Convert the code in a component into VOPs.
 (defun ir2-convert (component)
   (declare (type component component))
@@ -1805,6 +1847,22 @@
                        2block
                        #!+sb-dyncount *dynamic-counts-tn* #!-sb-dyncount nil
                        num))))
+              #!+sb-safepoint
+              (let ((first-node (block-start-node block)))
+                (unless (or (and (bind-p first-node)
+                                 (xep-p (bind-lambda first-node)))
+                            (and (valued-node-p first-node)
+                                 (node-lvar first-node)
+                                 (eq (lvar-fun-name
+                                      (node-lvar first-node))
+                                     '%nlx-entry)))
+                  (when (and (rest (block-pred block))
+                             (block-loop block)
+                             (member (loop-kind (block-loop block))
+                                     '(:natural :strange))
+                             (eq block (loop-head (block-loop block)))
+                             (policy first-node (< inhibit-safepoints 2)))
+                    (vop sb!vm::insert-safepoint first-node 2block))))
             (ir2-convert-block block)
             (incf num))))))
   (values))