Instruction explosion for char->integer

* module/language/cps/effects-analysis.scm:
* module/language/cps/slot-allocation.scm (compute-var-representations):
* module/language/cps/types.scm:
* module/language/cps/compile-bytecode.scm (compile-function): Remove
  char->integer cases.
* module/system/vm/assembler.scm: Remove emit-char->integer export.
* module/language/tree-il/compile-cps.scm (char->integer): Define
  instruction exploder.

module/language/cps/compile-bytecode.scm

@@ -175,8 +175,6 @@
         (($ $primcall 'tail-pointer-ref/immediate (annotation . idx) (obj))
          (emit-tail-pointer-ref/immediate asm (from-sp dst) (from-sp (slot obj))
                                           idx))
-        (($ $primcall 'char->integer #f (src))
-         (emit-char->integer asm (from-sp dst) (from-sp (slot src))))
         (($ $primcall 'add/immediate y (x))
          (emit-add/immediate asm (from-sp dst) (from-sp (slot x)) y))
         (($ $primcall 'sub/immediate y (x))

module/language/cps/effects-analysis.scm

@@ -544,8 +544,7 @@ the LABELS that are clobbered by the effects of LABEL."
 ;; Characters.
 (define-primitive-effects
   ((untag-char _))
-  ((tag-char _))
-  ((char->integer _)               &type-check))
+  ((tag-char _)))
 
 ;; Atomics are a memory and a compiler barrier; they cause all effects
 ;; so no need to have a case for them here.  (Though, see

module/language/cps/slot-allocation.scm

@@ -751,7 +751,7 @@ are comparable with eqv?.  A tmp slot may be used."
                                'fadd 'fsub 'fmul 'fdiv))
               (intmap-add representations var 'f64))
              (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
-                               'char->integer 's64->u64
+                               's64->u64
                                'assume-u64
                                'uadd 'usub 'umul
                                'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh

module/language/cps/types.scm

@@ -1605,10 +1605,6 @@ minimum, and maximum."
 (define-type-inferrer (tag-char u64 result)
   (define! result &char 0 (min (&max u64) *max-codepoint*)))
 
-(define-type-inferrer (char->integer c result)
-  (restrict! c &char 0 *max-codepoint*)
-  (define! result &u64 (&min/0 c) (min (&max c) *max-codepoint*)))
-
 
 
 

module/language/tree-il/compile-cps.scm

@@ -1300,8 +1300,6 @@
 
 (define-primcall-converter integer->char
   (lambda (cps k src op param i)
-    ;; Precondition: SLEN is a non-negative S64 that is representable as a
-    ;; fixnum.
     (define not-fixnum
       #(wrong-type-arg
         "integer->char"
@@ -1340,9 +1338,26 @@
               ($continue kbound0 src ($primcall 'untag-fixnum #f (i)))))
       (build-term ($branch knot-fixnum kuntag src 'fixnum? #f (i))))))
 
-(define-primcall-converters
-  (char->integer scm >u64)
+(define-primcall-converter char->integer
+  (lambda (cps k src op param ch)
+    (define not-char
+      #(wrong-type-arg
+        "char->integer"
+        "Wrong type argument in position 1 (expecting char): ~S"))
+    (with-cps cps
+      (letv ui si)
+      (letk knot-char
+            ($kargs () () ($throw src 'throw/value+data not-char (ch))))
+      (letk ktag ($kargs ('si) (si)
+                   ($continue k src ($primcall 'tag-fixnum #f (si)))))
+      (letk kcvt ($kargs ('ui) (ui)
+                   ($continue ktag src ($primcall 'u64->s64 #f (ui)))))
+      (letk kuntag ($kargs () ()
+                     ($continue kcvt src ($primcall 'untag-char #f (ch)))))
+      (build-term
+        ($branch knot-char kuntag src 'char? #f (ch))))))
 
+(define-primcall-converters
   (rsh scm u64 >scm)
   (lsh scm u64 >scm))
 

module/system/vm/assembler.scm

@@ -259,7 +259,6 @@
             emit-ursh/immediate
             emit-srsh/immediate
             emit-ulsh/immediate
-            emit-char->integer
             emit-class-of
             emit-make-array
             emit-scm->f64