From: Nikodemus Siivola <nikodemus@sb-studio.net>
Date: Fri, 4 May 2012 09:43:40 +0000 (+0300)
Subject: don't unconditionally unparse CHARACTER-SET types into MEMBER types
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=33564311979de0cb8798884c377e491cfb416b95;p=sbcl.git

don't unconditionally unparse CHARACTER-SET types into MEMBER types

  Doing so means dumping a list containing most of unicode for each
  function that return something like

    (code-char (+ <const> <(integer 0)>))

  which has a derived type (CHARACTER-SET ((<const> . 1114111))).

  Instead, pick whichever is more compact, using number of characters
  vs number of character code ranges as the deciding factor.

  This means that users can see SB-KERNEL:CHARACTER-SET types in
  eg. output from DESCRIBE or as return values from
  SB-INTROSPECT:FUNCTION-TYPE -- which is suboptimal, but less bad
  than such types slowing us down as horribly as they do prior to this
  change.

  At some point, however, we should document and export SB-EXT:CHARSET
  or something -- but I don't want to think of the issues associated
  with a public interface right now.
---

diff --git a/NEWS b/NEWS
index eda0e56..d7ef0f1 100644
--- a/NEWS
+++ b/NEWS
@@ -30,6 +30,8 @@ changes relative to sbcl-1.0.56:
   * optimization: typechecking alien values is typically 5 x faster.
   * optimization: FDEFINITION, SYMBOL-FUNCTION, MACRO-FUNCTION, and FBOUNDP
     are 20% faster.
+  * bug fix: file compilation performance issues when dumping subtypes
+    of CHARACTER (lp#994487)
   * bug fix: fixed disassembly of some SSE instructions on x86-64.
   * bug fix: SB-SIMPLE-STREAMS signals an error for bogus :CLASS arguments in
     OPEN. (lp#969352, thanks to Kambiz Darabi)
diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index d1eaa9e..63431b9 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -3297,10 +3297,20 @@ used for a COMPLEX component.~:@>"
     ((type= type (specifier-type 'base-char)) 'base-char)
     ((type= type (specifier-type 'extended-char)) 'extended-char)
     ((type= type (specifier-type 'standard-char)) 'standard-char)
-    (t (let ((pairs (character-set-type-pairs type)))
-        `(member ,@(loop for (low . high) in pairs
+    (t
+     ;; Unparse into either MEMBER or CHARACTER-SET. We use MEMBER if there
+     ;; are at most as many characters than there are character code ranges.
+     (let* ((pairs (character-set-type-pairs type))
+            (count (length pairs))
+            (chars (loop named outer
+                         for (low . high) in pairs
                          nconc (loop for code from low upto high
-                                     collect (sb!xc:code-char code))))))))
+                                     collect (sb!xc:code-char code)
+                                     when (minusp (decf count))
+                                     do (return-from outer t)))))
+       (if (eq chars t)
+           `(character-set ,pairs)
+           `(member ,@chars))))))
 
 (!define-type-method (character-set :singleton-p) (type)
   (let* ((pairs (character-set-type-pairs type))
diff --git a/tests/character.pure.lisp b/tests/character.pure.lisp
index 015d347..cfa1d2b 100644
--- a/tests/character.pure.lisp
+++ b/tests/character.pure.lisp
@@ -118,3 +118,10 @@
     (assert-coercion (code-char 955) character)
     (assert-coercion 'a character)
     (assert-coercion "a" character)))
+
+(with-test (:name :bug-994487)
+  (let ((f (compile nil `(lambda (char)
+                           (code-char (1+ (char-code char)))))))
+    (assert (equal `(function (t) (values (sb-kernel:character-set ((1 . 1114111)))
+                                          &optional))
+                   (sb-impl::%fun-type f)))))