1.0.25.54: centralize scattered arch_os_get_context() calls

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

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 231ce84..49616d4 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2616,6 +2616,27 @@
              (hi-res (if hi (isqrt hi) '*)))
         (specifier-type `(integer ,lo-res ,hi-res))))))
 
+(defoptimizer (char-code derive-type) ((char))
+  (let ((type (type-intersection (lvar-type char) (specifier-type 'character))))
+    (cond ((member-type-p type)
+           (specifier-type
+            `(member
+              ,@(loop for member in (member-type-members type)
+                      when (characterp member)
+                      collect (char-code member)))))
+          ((sb!kernel::character-set-type-p type)
+           (specifier-type
+            `(or
+              ,@(loop for (low . high)
+                      in (character-set-type-pairs type)
+                      collect `(integer ,low ,high)))))
+          ((csubtypep type (specifier-type 'base-char))
+           (specifier-type
+            `(mod ,base-char-code-limit)))
+          (t
+           (specifier-type
+            `(mod ,char-code-limit))))))
+
 (defoptimizer (code-char derive-type) ((code))
   (let ((type (lvar-type code)))
     ;; FIXME: unions of integral ranges?  It ought to be easier to do
@@ -3392,10 +3413,6 @@
   (def eq)
   (def char=))
 
-;;; True if EQL comparisons involving type can be simplified to EQ.
-(defun eq-comparable-type-p (type)
-  (csubtypep type (specifier-type '(or fixnum (not number)))))
-
 ;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also
 ;;; try to convert to a type-specific predicate or EQ:
 ;;; -- If both args are characters, convert to CHAR=. This is better than
@@ -3820,7 +3837,7 @@
 ;;; error messages, and those don't need to be particularly fast.
 #+sb-xc
 (deftransform format ((dest control &rest args) (t simple-string &rest t) *
-                      :policy (> speed space))
+                      :policy (>= speed space))
   (unless (constant-lvar-p control)
     (give-up-ir1-transform "The control string is not a constant."))
   (let ((arg-names (make-gensym-list (length args))))
@@ -3828,15 +3845,13 @@
        (declare (ignore control))
        (format dest (formatter ,(lvar-value control)) ,@arg-names))))
 
-(deftransform format ((stream control &rest args) (stream function &rest t) *
-                      :policy (> speed space))
+(deftransform format ((stream control &rest args) (stream function &rest t))
   (let ((arg-names (make-gensym-list (length args))))
     `(lambda (stream control ,@arg-names)
        (funcall control stream ,@arg-names)
        nil)))
 
-(deftransform format ((tee control &rest args) ((member t) function &rest t) *
-                      :policy (> speed space))
+(deftransform format ((tee control &rest args) ((member t) function &rest t))
   (let ((arg-names (make-gensym-list (length args))))
     `(lambda (tee control ,@arg-names)
        (declare (ignore tee))
@@ -4079,19 +4094,16 @@
                        (specifier-type (consify element-type)))
                       (t
                        (error "can't understand type ~S~%" element-type))))))
-      (cond ((array-type-p array-type)
-             (get-element-type array-type))
-            ((union-type-p array-type)
-             (apply #'type-union
-                    (mapcar #'get-element-type (union-type-types array-type))))
-            (t
-             *universal-type*)))))
+      (labels ((recurse (type)
+                  (cond ((array-type-p type)
+                         (get-element-type type))
+                        ((union-type-p type)
+                         (apply #'type-union
+                                (mapcar #'recurse (union-type-types type))))
+                        (t
+                         *universal-type*))))
+        (recurse array-type)))))
 
-;;; Like CMU CL, we use HEAPSORT. However, other than that, this code
-;;; isn't really related to the CMU CL code, since instead of trying
-;;; to generalize the CMU CL code to allow START and END values, this
-;;; code has been written from scratch following Chapter 7 of
-;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
 (define-source-transform sb!impl::sort-vector (vector start end predicate key)
   ;; Like CMU CL, we use HEAPSORT. However, other than that, this code
   ;; isn't really related to the CMU CL code, since instead of trying